$CONTROL USLINIT,CODE,MAP                                      <<01549>>00010000
<< cifiles of the command interpreter.  module 5a >>           <<04848>>00015000
<< hp32002c mpe source c.00.00 >>                                       00020000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00025000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00030000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00035000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00040000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00045000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00050000
$thirty                                                                 00055000
$title "IMS"                                                            00060000
$control nolist                                                         00065000
<<*****************  command interpreter ims  *****************<<u.rao>>00070000
<<*************************************************************<<u.rao>>00075000
<<                                                             <<u.rao>>00080000
<<*************************************************************<<u.rao>>00085000
<<************************  overview  *************************<<u.rao>>00090000
<<*************************************************************<<u.rao>>00095000
<<                                                             <<u.rao>>00100000
<<who:                                                         <<u.rao>>00105000
<<   larry birenbaum designed the basic structures of the      <<u.rao>>00110000
<<command interpreter for version a of mpe.  work was begun in <<u.rao>>00115000
<<1970 or 1971.                                                <<u.rao>>00120000
<<   bob olson substantially redesigned the parsers of the     <<u.rao>>00125000
<<command interpreter for version b of mpe ii.  work was begun <<u.rao>>00130000
<<in november 1976 and completed in late 1977.  the basic      <<u.rao>>00135000
<<algorithms for executing the commands remained essentially   <<u.rao>>00140000
<<the same even though the parsers were rewritten.  several    <<u.rao>>00145000
<<new commands were added at this time, as were user defined   <<u.rao>>00150000
<<commands.                                                    <<u.rao>>00155000
<<   other people who have added commands or modified existing <<u.rao>>00160000
<<commands for mpe iib are ron hoyt and bob vannucci (private  <<u.rao>>00165000
<<volumes, including modification of the accounting commands   <<u.rao>>00170000
<<and store/restore), neal mack (transaction logging user      <<u.rao>>00175000
<<commands), mike philben (revision of ds commands), ed basart <<u.rao>>00180000
<<(revision of hello, job, and data and the addition of user   <<u.rao>>00185000
<<defined commands), and bob gerstmeyer (cline command).       <<u.rao>>00190000
<<                                                             <<u.rao>>00195000
<<where:                                                       <<u.rao>>00200000
<<   pieces of the command interpreter are scattered all over  <<u.rao>>00205000
<<the system.  this module contains the bulk of the executors. <<u.rao>>00210000
<<the spooling commands (showjob, showout, stream, and showin) <<u.rao>>00215000
<<may be found in the spoolcoms module.  the ds commands       <<u.rao>>00220000
<<(rfa, dsline, remote) will be found in the ds code.  store   <<u.rao>>00225000
<<and restore have a module of their own.  the bulk of the work<<u.rao>>00230000
<<for user defined commands is done in a module called udc.    <<u.rao>>00235000
<<help resides in module helpuser.  job, hello and data are    <<u.rao>>00240000
<<parsed by code in module nursery.  in general, it is better  <<u.rao>>00245000
<<to put the executors in the same module as the routines which<<u.rao>>00250000
<<do the work.  this will reduce confusion and simplify        <<u.rao>>00255000
<<maintenance.  there is no inherent benefit to accumulating   <<u.rao>>00260000
<<executors in common segments, assuming that there is         <<u.rao>>00265000
<<non-trivial work to do.                                      <<u.rao>>00270000
<<                                                             <<u.rao>>00275000
<<why:                                                         <<u.rao>>00280000
<<   the purpose served by the command interpreter is to       <<u.rao>>00285000
<<provide the user access to the operating system functions    <<u.rao>>00290000
<<without requiring him/her to go through the irritation of    <<u.rao>>00295000
<<writing a program to do so.  there are three primary function<<u.rao>>00300000
<<provided by the commands.  most important is the ability to  <<u.rao>>00305000
<<execute programs, evidenced by the run command and the variou<<u.rao>>00310000
<<compiler commands.  second is the ability to manage one's    <<u.rao>>00315000
<<resources, such as files.  finally there are a large number o<<u.rao>>00320000
<<utility functions, primarily for status checking.  when a new<<u.rao>>00325000
<<capability is added to the system, the user should be given  <<u.rao>>00330000
<<commands which allow him to manipulate the capability and to <<u.rao>>00335000
<<determine the status of the new resource created by the      <<u.rao>>00340000
<<capability.                                                  <<u.rao>>00345000
<<                                                             <<u.rao>>00350000
$page                                                                   00355000
<<*************************************************************<<u.rao>>00360000
<<****************  adding a command to the ci  ***************<<u.rao>>00365000
<<*************************************************************<<u.rao>>00370000
<<                                                             <<u.rao>>00375000
<<step 1:  designing the command.                              <<u.rao>>00380000
<<   a reasonable and parseable command syntax is one of the   <<u.rao>>00385000
<<important parts of designing a good command.  your goal is   <<u.rao>>00390000
<<to minimize user irritation when using the command.  always  <<u.rao>>00395000
<<remember that for most users the problem for which they are  <<u.rao>>00400000
<<using a computer is probably solved within an application    <<u.rao>>00405000
<<program of some sort and the command interpreter in general  <<u.rao>>00410000
<<and your command in particular are necessary annoyances.     <<u.rao>>00415000
<<you must strive to limit that annoyance to the unavoidable.  <<u.rao>>00420000
<<   unfortunately, there are a wide variety of ways in which  <<u.rao>>00425000
<<you can annoy people.  some of the solutions are mutually    <<u.rao>>00430000
<<incompatible.  the following is a list of the issues you     <<u.rao>>00435000
<<should consider.                                             <<u.rao>>00440000
<<   1)  verbose versus terse command names                    <<u.rao>>00445000
<<       in general it is desireable to have command names     <<u.rao>>00450000
<<       which accurately reflect the function of the          <<u.rao>>00455000
<<       command.  the tradeoff is that verbose command        <<u.rao>>00460000
<<       names which describe the command are easier to        <<u.rao>>00465000
<<       pick out in documentation whereas terse names are     <<u.rao>>00470000
<<       easier to type.  thus the deciding factor should      <<u.rao>>00475000
<<       be how often the user will use the command.  a        <<u.rao>>00480000
<<       side consideration is that the use of archaic         <<u.rao>>00485000
<<       english or bizarre abbreviations will work a          <<u.rao>>00490000
<<       hardship on our users who are not native english      <<u.rao>>00495000
<<       speakers.                                             <<u.rao>>00500000
<<   2)  keyword versus positional parameters                  <<u.rao>>00505000
<<       positional parameters can be dangerous, especially    <<u.rao>>00510000
<<       when the parameters can be similar data types.        <<u.rao>>00515000
<<       for example, a positional string of numbers can       <<u.rao>>00520000
<<       result in erroneous operation due to the accidental   <<u.rao>>00525000
<<       omission of a delimiter.  keyworded parameters        <<u.rao>>00530000
<<       can be very verbose, especially on complex commands.  <<u.rao>>00535000
<<       they can also work a hardship when a user uses a      <<u.rao>>00540000
<<       particular command heavily, since it drastically      <<u.rao>>00545000
<<       enlarges the amount of typing.  this last objection   <<u.rao>>00550000
<<       can be gotten around through the agency of user       <<u.rao>>00555000
<<       defined commands.  another major objection to         <<u.rao>>00560000
<<       keywords is that it requires several different        <<u.rao>>00565000
<<       delimiters, often leading to typing errors and        <<u.rao>>00570000
<<       mental confusion.                                     <<u.rao>>00575000
<<   3)  delimiters & other special characters                 <<u.rao>>00580000
<<       the typical delimiters in commands are commas to      <<u.rao>>00585000
<<       separate positional parameters and semicolons to      <<u.rao>>00590000
<<       separate keywords.  the file command shows this       <<u.rao>>00595000
<<       in full generality.  periods are sometimes            <<u.rao>>00600000
<<       terminators (as in the label option on the file       <<u.rao>>00605000
<<       command) and sometimes separators, as in the logon    <<u.rao>>00610000
<<       user id and file names.  blanks are tough to deal     <<u.rao>>00615000
<<       with and should be avoided as delimiters.             <<u.rao>>00620000
<<       non-printing characters should be avoided at all      <<u.rao>>00625000
<<       costs.  all commands will be terminated with a        <<u.rao>>00630000
<<       carriage return when passed to the command parser.    <<u.rao>>00635000
<<   4)  hardware/software peculiarities                       <<u.rao>>00640000
<<       too frequently the command syntax reflects some       <<u.rao>>00645000
<<       strange and unpleasant aspect of the mechanism        <<u.rao>>00650000
<<       underlying the command.  we should not require the    <<u.rao>>00655000
<<       user to be cognizant of our design problems.  to      <<u.rao>>00660000
<<       do so violates the principle of lowering the          <<u.rao>>00665000
<<       annoyance factor.                                     <<u.rao>>00670000
<<   5)  extensibility                                         <<u.rao>>00675000
<<       no matter how well your command does its job, one     <<u.rao>>00680000
<<       of these days someone will want to modify or          <<u.rao>>00685000
<<       extend it.  in particular, one should be careful      <<u.rao>>00690000
<<       about the use of delimiters in ways other than the    <<u.rao>>00695000
<<       "traditional" way.  for example, periods, commas,     <<u.rao>>00700000
<<       semicolons and others have fairly standardized        <<u.rao>>00705000
<<       meanings, and to use them in a different way reduces  <<u.rao>>00710000
<<       the options of your successor to extend your command. <<u.rao>>00715000
<<       another related issue is that listing formats should  <<u.rao>>00720000
<<       be extensible.                                        <<u.rao>>00725000
<<   6)  defaults                                              <<u.rao>>00730000
<<       defaults are vital, dangerous and difficult to choose.<<u.rao>>00735000
<<       the design goal is that the command should be simple  <<u.rao>>00740000
<<       for simple minded users.  this implies restraint in   <<u.rao>>00745000
<<       the use of defaults which vary depending on some other<<u.rao>>00750000
<<       parameter to the command.  too smart defaults can be  <<u.rao>>00755000
<<       just as bad as no defaults, since many users will     <<u.rao>>00760000
<<       use the command defensively to avoid surprises from   <<u.rao>>00765000
<<       the default mechanism.  good luck.                    <<u.rao>>00770000
<<   7)  ambiguity                                             <<u.rao>>00775000
<<       careful design will avoid the need for lookahead to   <<u.rao>>00780000
<<       resolve abiguous situations.  lookahead should be     <<u.rao>>00785000
<<       avoided if at all possible, as it results in          <<u.rao>>00790000
<<       much code with complicated data structures.           <<u.rao>>00795000
<<   8)  computerese                                           <<u.rao>>00800000
<<       keywords should be couched in english, not computerese<<u.rao>>00805000
<<                                                             <<u.rao>>00810000
<<in summary, the user of your command will probably not be a  <<u.rao>>00815000
<<computer professional and probably will be annoyed at the nee<<u.rao>>00820000
<<to use your command at all.  simplicity, understandability an<<u.rao>>00825000
<<regularity are the keys to good command syntax.              <<u.rao>>00830000
<<                                                             <<u.rao>>00835000
<<step 2: code the executor.                                   <<u.rao>>00840000
<<   for the most part this is quite straightforward.  most of <<u.rao>>00845000
<<the existing executors can be used as models.  there are a fe<<u.rao>>00850000
<<good concepts to keep in mind, however.                      <<u.rao>>00855000
<<   generating good error messages is just as important as    <<u.rao>>00860000
<<executing the command.  the whole error message issue is deal<<u.rao>>00865000
<<with below.                                                  <<u.rao>>00870000
<<   the code of the command should be easily extensible.  this<<u.rao>>00875000
<<implies the use of a simple parsing scheme with very obvious <<u.rao>>00880000
<<techniques.  probably more often than any other part of the  <<u.rao>>00885000
<<system, the ci is modified by people who have no proprietary <<u.rao>>00890000
<<interest in it.  in the interests of reliability and         <<u.rao>>00895000
<<maintainability, it is desireable to start with as clean code<<u.rao>>00900000
<<as possible.  unfortunately, no universal parsing scheme has <<u.rao>>00905000
<<yet been developed for the ci.                               <<u.rao>>00910000
<<   A trap to avoid is called the "parse a little, execute a  <<U.RAO>>00915000
<<little" syndrome.  It results in the need to back out of a   <<U.RAO>>00920000
<<situation when an error is detected further down stream.  a  <<u.rao>>00925000
<<secondary problem is that it tends to result in the          <<u.rao>>00930000
<<partial destruction of the context of the error.  a command  <<u.rao>>00935000
<<should be parsed completely before being executed at all.    <<u.rao>>00940000
<<   don't worry about having particularly efficient code.  the<<u.rao>>00945000
<<ci's execution time is trivial compared to the time it takes <<u.rao>>00950000
<<for the user to recover from a poorly designed error message <<u.rao>>00955000
<<or even from a poorly designed syntax.  the customer always  <<u.rao>>00960000
<<comes first.                                                 <<u.rao>>00965000
<<   the use of global storage is discouraged.  most important <<u.rao>>00970000
<<is the fact that there are some performance consequences     <<u.rao>>00975000
<<related to the need to constantly enlarge the ci's stack.    <<u.rao>>00980000
<<if you find you do need global storage, be sure to initialize<<u.rao>>00985000
<<it in procedure commandinterp, as the ci is procreated and   <<u.rao>>00990000
<<thus has no global initialization capability.  be careful    <<u.rao>>00995000
<<about where you put new globals.  certain other modules such <<u.rao>>01000000
<<as udc know about the ci global space.                       <<u.rao>>01005000
<<   in general, the execution part of the command should simpl<<u.rao>>01010000
<<be a call to the appropriate user callable intrinsic.  the   <<u.rao>>01015000
<<ci usually should not provide the user any special services  <<u.rao>>01020000
<<that are not available programmatically.  in this way we avoi<<u.rao>>01025000
<<such undesireable situations as users getting their accountin<<u.rao>>01030000
<<information through a call to the report command and setting <<u.rao>>01035000
<<up their files through a call to the file command through the<<u.rao>>01040000
<<command intrinsic.  see the setjcw command for an example of <<u.rao>>01045000
<<this.                                                        <<u.rao>>01050000
<<   exchangedb is to be avoided if at all possible, even if   <<u.rao>>01055000
<<you have to do data segment moves iteratively.  the speed cos<<u.rao>>01060000
<<is nothing compared to the cost of the crash which is        <<u.rao>>01065000
<<inevitable when doing split stack operations.  all of the ci <<u.rao>>01070000
<<utility routines assume no split stack operation.            <<u.rao>>01075000
<<   similarly there is rarely any valid reason for accessing  <<u.rao>>01080000
<<system primitives directly from the ci.  the ci should be a  <<u.rao>>01085000
<<very high level module.  it rarely has any business rooting  <<u.rao>>01090000
<<around in some system table.  this principle unfortunately ha<<u.rao>>01095000
<<been rather imperfectly adhered to.                          <<u.rao>>01100000
<<   these almost random thoughts about writing executors hardl<<u.rao>>01105000
<<provide a good framework for writing code.  cursory          <<u.rao>>01110000
<<examination of some of the executors currently in the module <<u.rao>>01115000
<<probably will give you a better idea of the tricks of the    <<u.rao>>01120000
<<trade.  a few ideas stand out.                               <<u.rao>>01125000
<<                                                             <<u.rao>>01130000
<<      code assuming someone else will be changing it.        <<u.rao>>01135000
<<                                                             <<u.rao>>01140000
<<      code for good error messages, not speed.               <<u.rao>>01145000
<<                                                             <<u.rao>>01150000
<<      it is far better to detect a problem at the            <<u.rao>>01155000
<<      time the command is put in than when it is             <<u.rao>>01160000
<<      executed.  that is, at parse time as opposed           <<u.rao>>01165000
<<      to execution time.                                     <<u.rao>>01170000
<<                                                             <<u.rao>>01175000
<<      cleverness will get you in trouble, usually for        <<u.rao>>01180000
<<      no good reason.                                        <<u.rao>>01185000
<<                                                             <<u.rao>>01190000
<<step 3:  add the command to the command interpreter.         <<u.rao>>01195000
<<   other than physically adding the executor to the system,  <<u.rao>>01200000
<<the only task is to add the command name to the list in      <<u.rao>>01205000
<<procedure comsearch.  this procedure is called for each      <<u.rao>>01210000
<<command to determine if it is one of the ones known to the   <<u.rao>>01215000
<<system.  the mechanics of this process are described in that <<u.rao>>01220000
<<procedure.  if the executor is physically outside the ci     <<u.rao>>01225000
<<module, don't forget to add the option external declaration. <<u.rao>>01230000
<<congratulations.  now all you need to do is make sure it     <<u.rao>>01235000
<<works.                                                       <<u.rao>>01240000
<<                                                             <<u.rao>>01245000
$page                                                                   01250000
<<*************************************************************<<u.rao>>01255000
<<**************  error messages from the ci  **************** <<u.rao>>01260000
<<*************************************************************<<u.rao>>01265000
<<                                                             <<u.rao>>01270000
<<philosophical aspects:                                       <<u.rao>>01275000
<<     the essential goal of an error message from the ci is to<<u.rao>>01280000
<<help the user quickly recover from his problem.  in general, <<u.rao>>01285000
<<a good error message should indicate:                        <<u.rao>>01290000
<<    1)  what the ci did not like.  on syntax errors this     <<u.rao>>01295000
<<        typically is done with a caret underneath where the  <<u.rao>>01300000
<<        problem was detected.  if the caret isn't sufficient <<u.rao>>01305000
<<        to identify the problem then some of the text of the <<u.rao>>01310000
<<        message should further elaborate.  on semantic errors<<u.rao>>01315000
<<        this usually is done with the text of the message.   <<u.rao>>01320000
<<    2)  how to recover.  this usually will take the form of  <<u.rao>>01325000
<<        telling the user what the valid input might be.  for <<u.rao>>01330000
<<        example, on an invalid record type in the :file      <<u.rao>>01335000
<<        command, the ci will put out a message something like<<u.rao>>01340000
<<        expected record type to be f, v or u.                <<u.rao>>01345000
<<        this serves to identify to the user very quickly what<<u.rao>>01350000
<<        the valid syntax is and thus how to get on with his  <<u.rao>>01355000
<<        business.  sometimes it is hard to figure out what th<<u.rao>>01360000
<<        user had in mind.  for example, it isn't really      <<u.rao>>01365000
<<        possible to second guess the user on an unknown      <<u.rao>>01370000
<<        command name.  in these relatively rare cases, it is <<u.rao>>01375000
<<        sufficient to tell the user just what was wrong.     <<u.rao>>01380000
<<        in general, if it is a syntax error of any sort, it  <<u.rao>>01385000
<<        is possible to give a good error message outlining   <<u.rao>>01390000
<<        what was expected.  a cop-out on this is really      <<u.rao>>01395000
<<        sloppy workmanship.                                  <<u.rao>>01400000
<<    3)  in many cases it is desireable to tell the user what <<u.rao>>01405000
<<        was done about the error.  this is particularly true <<u.rao>>01410000
<<        in the case of warnings, where the user may be left  <<u.rao>>01415000
<<        wondering whether some default was taken.  for exampl<<u.rao>>01420000
<<        in the accounting structure commands we ignore many  <<u.rao>>01425000
<<        errors.  in each case it is necessary to tell the use<<u.rao>>01430000
<<        what default we took so that he can then do an altxxx<<u.rao>>01435000
<<        to fix up the particular error, if necessary.  of    <<u.rao>>01440000
<<        course, in each case we try to pick a reasonable     <<u.rao>>01445000
<<        default so that he doesn't have to do any recovery.  <<u.rao>>01450000
<<                                                             <<u.rao>>01455000
<<in any case, messages should be very specific.  given the    <<u.rao>>01460000
<<very simple mechanism for generating error and warning       <<u.rao>>01465000
<<messages, there is no acceptable excuse for generic messages.<<u.rao>>01470000
<<examples:                                                    <<u.rao>>01475000
<<   "INVALID NUMBER" is unacceptable.  such messages should be<<u.rao>>01480000
<<of the form "EXPECTED <item> TO BE BETWEEN <n1> AND <n2>."   <<u.rao>>01485000
<<this message should be used only once in the ci.             <<u.rao>>01490000
<<   "UNKNOWN KEYWORD" is unacceptable.  the proper form is    <<u.rao>>01495000
<<"EXPECTED ONE OF <item1>, <item2>....".                      <<u.rao>>01500000
<<   in general, "<item>", "<n1>" and so forth should not be   <<u.rao>>01505000
<<passed to cierr as parameters but rather be embedded as part <<u.rao>>01510000
<<of the error message.  the reason for this is that you will  <<u.rao>>01515000
<<need to give a fuller description of the error in the error  <<u.rao>>01520000
<<messages part of the mpe manual.  it is awkward at best and  <<u.rao>>01525000
<<embarrassing at worst to have to tell the manual writer "Well<<U.RAO>>01530000
<<it could be this, or it could be that, or even this third    <<u.rao>>01535000
<<thing."  The one exception is where truly dynamic information<<U.RAO>>01540000
<<is involved.  examples might include configuration data and  <<u.rao>>01545000
<<user supplied information like file names.>>                 <<u.rao>>01550000
<<   in most cases, redundantly specified parameters should    <<u.rao>>01555000
<<result not in a fatal error but in a warning.  if a value is <<u.rao>>01560000
<<associated with the redundant keyword then the message should<<u.rao>>01565000
<<specify that the last value found was used.                  <<u.rao>>01570000
<<   similarly unacceptable messages are                       <<u.rao>>01575000
<<   "INSUFFICIENT PARAMETERS" - what is missing?              <<u.rao>>01580000
<<   "INSUFFICIENT CAPABILITY" should say what capability is   <<u.rao>>01585000
<<missing.                                                     <<u.rao>>01590000
<<   "INSUFFICIENT RESOURCES" should say what resources are    <<u.rao>>01595000
<<lacking.                                                     <<u.rao>>01600000
<<and so forth for all messages.                               <<u.rao>>01605000
<<                                                             <<u.rao>>01610000
<<mechanical aspects of adding error messages:                 <<u.rao>>01615000
<<                                                             <<u.rao>>01620000
<<1)  numbering                                                <<u.rao>>01625000
<<    the number chosen for a message is largely irrelevant.  i<<u.rao>>01630000
<<    is nice, however, if it is near the other messages       <<u.rao>>01635000
<<    associated with the same command.  be sure to declare it <<u.rao>>01640000
<<    as an equate in the ci globals (or spoolcoms or whatever)<<u.rao>>01645000
<<    note that the message should be tagged as to whether it i<<u.rao>>01650000
<<    a cierr or ciwarn or whatever.  put it in message set 2. <<u.rao>>01655000
<<2)  generation                                               <<u.rao>>01660000
<<    there is a procedure called cierr which is responsible fo<<u.rao>>01665000
<<    processing related to the handling of errors.  in        <<u.rao>>01670000
<<    particular this procedure decides whether to print the   <<u.rao>>01675000
<<    message, abort the job, and other related cleanup        <<u.rao>>01680000
<<    problems.  note that it always returns to the caller if  <<u.rao>>01685000
<<    the job is not aborted.  it is the responsibility of the <<u.rao>>01690000
<<    caller to assure that the job is clean enough to be      <<u.rao>>01695000
<<    aborted at the time of the call.  cierr cannot be called <<u.rao>>01700000
<<    in split stack mode.  see the listing of cierr for the   <<u.rao>>01705000
<<    details of the call.                                     <<u.rao>>01710000
<<3)  errors detected by other parts of the system.            <<u.rao>>01715000
<<    errors such as file system errors, loader errors, ds     <<u.rao>>01720000
<<    runtime errors and private volume errors are really of   <<u.rao>>01725000
<<    little meaning in the context of the ci.  accordingly,   <<u.rao>>01730000
<<    when such errors are detected, several messages may be   <<u.rao>>01735000
<<    displayed.  this is done through the agency of routines  <<u.rao>>01740000
<<    like ferror', cydirerr', loaderror, and createerror.     <<u.rao>>01745000
<<    the development of such routines is encouraged whenever  <<u.rao>>01750000
<<    message sets outside the ci error message set is         <<u.rao>>01755000
<<    involved.  when such a message is output, the ci should  <<u.rao>>01760000
<<    also print a message translating the error into the      <<u.rao>>01765000
<<    context of the command which failed.  for example, when  <<u.rao>>01770000
<<    a purge fails for an unusual reason, we print the file   <<u.rao>>01775000
<<    system error message as well as a message saying that the<<u.rao>>01780000
<<    purge was not done.                                      <<u.rao>>01785000
<<4)  general purpose parsing routines                         <<u.rao>>01790000
<<    some parses, such as file names, are done so often that  <<u.rao>>01795000
<<    generalized routines exist.  usually these will be found <<u.rao>>01800000
<<    in the neighborhood of the error handling routines.      <<u.rao>>01805000
<<5)  programmatically callable commands                       <<u.rao>>01810000
<<    for errors in programmatically callable commands you must<<u.rao>>01815000
<<    also return the error number to the caller of the command<<u.rao>>01820000
<<    intrinsic.  this is done by returning the number through <<u.rao>>01825000
<<    the errnum parameter to all executors.  also it is       <<u.rao>>01830000
<<    required that you return the parameter number in the     <<u.rao>>01835000
<<    parmnum parameter.  parameter number is roughly defined  <<u.rao>>01840000
<<    as one for each entity such as a keyword or value past   <<u.rao>>01845000
<<    the command name.  in other words, 1 is the first        <<u.rao>>01850000
<<    parameter past the command name, 2 might be the value to <<u.rao>>01855000
<<    be associated with the keyword which was parameter 1.    <<u.rao>>01860000
<<                                                             <<u.rao>>01865000
<<   error message generation is one of the most important     <<u.rao>>01870000
<<tasks to be performed by the command interpreter.  the best  <<u.rao>>01875000
<<error messages are generated when the coder tries to envision<<u.rao>>01880000
<<the user's perception of the error.  for example, in many    <<u.rao>>01885000
<<cases it seems to the user that it was obvious what he meant <<u.rao>>01890000
<<even though it was not expressed in correct form.  this      <<u.rao>>01895000
<<includes redundantly specified keywords like nocctl in the   <<u.rao>>01900000
<<file command.  the user does not think highly of a command   <<u.rao>>01905000
<<parser which gives him an error message on something like tha<<u.rao>>01910000
<<which is obviously non-fatal.  the key to success with error <<u.rao>>01915000
<<messages is to identify errors in the user's frame of        <<u.rao>>01920000
<<reference, not the system programmer's.                      <<u.rao>>01925000
<<                                                             <<u.rao>>01930000
$title "GLOBAL DECLARATIONS"                                            01935000
$page "GLOBAL DECLARATIONS"                                             01940000
$control main=command'interp                                   <<06.eb>>01945000
begin                                                                   01950000
      <<miscellaneous declarations >>                                   01955000
      integer                                                           01960000
      deltaq=q-0,                                                       01965000
      s0=s-0,                                                           01970000
      s4=s-4,                                                           01975000
      xreg = x,                                                         01980000
      x=x;                                                              01985000
                                                                        01990000
      logical                                                           01995000
      ls0=s-0,                                                          02000000
      status=q-1;                                                       02005000
                                                                        02010000
      double                                                            02015000
      ds1=s-1,                                                          02020000
      ds3=s-3;                                                 << i.a >>02025000
                                                                        02030000
      byte pointer                                                      02035000
      bps0=s-0,                                                         02040000
      bps1=s-1;                                                         02045000
                                                                        02050000
      integer pointer                                                   02055000
      ps0=s-0;                                                 << i.a >>02060000
                                                                        02065000
      double pointer                                                    02070000
      dps1 = s-1;                                              <<u.rao>>02075000
                                                                        02080000
      integer array arrdb0(*)=db+0;                                     02085000
      integer array arrdb2(*)=db+2;                                     02090000
      integer array arrdb3(*)=db+3;                                     02095000
      integer array arrdb5(*)=db+5;                                     02100000
      integer array arrdb6(*)=db+6;                                     02105000
      integer array arrq0(*)=q-0;                                       02110000
      integer array arrs7(*)=s-7;                                       02115000
$include inclpxg                                               <<06567>>02120000
$set x8=off                                                    <<06571>>02125000
$include incljmat                                              <<06571>>02130000
$include inclcis                                               << i.a >>02135000
$page "GLOBAL DECLARATIONS"                                    << i.a >>02140000
$include incljit                                               <<06840>>02145000
                                                               <<09.eb>>02150000
      <<equates used throughout>>                                       02155000
                                                                        02160000
      equate                                                            02165000
      << series 33 cpu number returned from 'thiscpu' >>       <<00492>>02170000
      <<condition codes>>                                               02175000
      cce=2,                                                            02180000
      ccl=1,                                                            02185000
      ccg=0,                                                            02190000
      <<ci message set numbers>>                               <<u.rao>>02195000
      cierrmsgset=2,                                           <<u.rao>>02200000
      cigeneralmsgset=7,                                       <<u.rao>>02205000
      pverrmsgset = 15,                                        <<rh.pv>>02210000
   <<equates for general messages (not error messages)>>       <<u.rao>>02215000
   endofprog       = 50,  <<end of program message>>           <<u.rao>>02220000
   << end of prepare = 51, >>                                  <<u.rao>>02225000
   << end of subsystem = 52, >>                                <<u.rao>>02230000
   << end of compile = 53, >>                                  <<u.rao>>02235000
   << end of remote program = 54>>                             <<u.rao>>02240000
   <<jcw = warn, msg 56>>                                      <<u.rao>>02245000
   <<jcw = fatal, msg 57>>                                     <<u.rao>>02250000
   <<jcw = system, msg 58>>                                    <<u.rao>>02255000
   <<ds message, msg 59>>                                      <<u.rao>>02260000
   <<ds message, msg 60>>                                      <<u.rao>>02265000
      <<error equates refer to c.i. error number>>                      02270000
                                                                        02275000
                                                                        02280000
                                                                        02285000
      <<command related errors>>                                        02290000
   paramtoobig     =  14,  <<parameter exceeds 255 chars>>     <<01709>>02295000
   <<file and build commands>>                                 <<u.rao>>02300000
   fdesgnolock     = 199  ,  <<no lockword in formal desgn.>>  <<04848>>02305000
   bld2mp          = 200  ,  <<more than 30 parms to build>>   <<u.rao>>02310000
   bldreqfilename  = 201  ,  <<name is required parm>>         <<u.rao>>02315000
   filefcodedefalt = 202  ,  <<file code missing - 0 default>> <<u.rao>>02320000
   file2mp         = 203  ,  <<more than 30 parms to build>>   <<u.rao>>02325000
   filereqfdesig   = 204  ,  <<requires formal designator>>    <<u.rao>>02330000
   filefdsgnoback  = 205  ,  <<fdesig may not be backref>>     <<u.rao>>02335000
   filefdsgnosys   = 206  ,  <<fdesig may not be sysdef file>> <<u.rao>>02340000
   filereqsomeparm = 207  ,  <<needs at least 2 parms>>        <<u.rao>>02345000
   fileadesigbr2mp = 208  ,  <<back ref may not have parms>>   <<u.rao>>02350000
   filebrefmisades = 209  ,  <<unable to find back ref'd file>><<u.rao>>02355000
   fileadesnull2mp = 210  ,  <<$null ades cannot have parms>>  <<u.rao>>02360000
   filedomainsysdf = 211  ,  <<cannot spec file domain>>       <<u.rao>>02365000
   filexpctdomain  = 212  ,  <<expected a file domain>>        <<u.rao>>02370000
   fileinvlddomain = 213  ,  <<unknown domain type>>           <<u.rao>>02375000
   filexstrtparmcr = 214  ,  <<expected start of parms>>       <<u.rao>>02380000
   fileextrandelim = 215  ,  <<extraneous parm delimiter>>     <<u.rao>>02385000
   filecontxtbld   = 216  ,  <<not appropriate for build>>     <<u.rao>>02390000
   filecontxtsysdf = 217  ,  <<not appropriate for sysdef file><<u.rao>>02395000
   filecontxtold   = 218  ,  <<not appropriate for old file>>  <<u.rao>>02400000
   filecontxtnew   = 219  ,  <<not appropriate for new file>>  <<u.rao>>02405000
   fileunknownkey  = 220  ,  <<unknown keyword for command>>   <<u.rao>>02410000
   filenocctlcctl  = 221  ,  <<cctl overrides nocctl>>         <<u.rao>>02415000
   filecctlnocctl  = 222  ,  <<nocctl overrides cctl>>         <<u.rao>>02420000
   filedeltemp     = 223  ,  <<temp overrides del>>            <<u.rao>>02425000
   filesavetemp    = 224  ,  <<temp overrides save>>           <<u.rao>>02430000
   filedelsave     = 225  ,  <<save overrides del>>            <<u.rao>>02435000
   filetempsave    = 226  ,  <<save overrides temp>>           <<u.rao>>02440000
   filetempdel     = 227  ,  <<del overrides temp>>            <<u.rao>>02445000
   filesavedel     = 228  ,  <<del overrides save>>            <<u.rao>>02450000
   fileexclshare   = 229  ,  <<shr overrides exclusive>>       <<u.rao>>02455000
   fileexclear     = 231  ,  <<ear overrides exc>>             <<u.rao>>02460000
   fileshareear    = 232  ,  <<ear overrides share>>           <<u.rao>>02465000
   fileearexcl     = 233  ,  <<exc overrides ear>>             <<u.rao>>02470000
   fileshareexcl   = 234  ,  <<exc overrides share>>           <<u.rao>>02475000
   filebufnobuf    = 235  ,  <<nobuf overrides buf>>           <<u.rao>>02480000
   filenomrmr      = 236  ,  <<mr overrides nomr>>             <<u.rao>>02485000
   filemrnomr      = 237  ,  <<nomr overrides mr>>             <<u.rao>>02490000
   filenomultimulti= 238  ,  <<multi overrides nomulti>>       <<u.rao>>02495000
   filemultinomulti= 239  ,  <<nomulti overrides multi>>       <<u.rao>>02500000
   filenowaitwait  = 240 ,  <<wait overrides nowait>>          <<u.rao>>02505000
   filewaitnowait  = 241 ,  <<nowait overrides wait>>          <<u.rao>>02510000
   filenoxpctsparm = 242 ,  <<no subparms for this key>>       <<u.rao>>02515000
   filereqeqsign   = 243 ,  <<expected equals sign>>           <<u.rao>>02520000
   fileaccessrednd = 244 ,  <<access redundantly specified>>   <<u.rao>>02525000
   fileaccreqvalue = 245 ,  <<access type required>>           <<u.rao>>02530000
   fileaccinvalid  = 246 ,  <<unknown access type>>            <<u.rao>>02535000
   fileaccxtrnparm = 247 ,  <<extraneous parm to access>>      <<u.rao>>02540000
   filenobufbuf    = 248 ,  <<buf overrides nobuf>>            <<u.rao>>02545000
   filebufoverride = 249 ,  <<buf overrides previous buf>>     <<u.rao>>02550000
   fileinvldbufnum = 250 ,  <<invalid number of buffers>>      <<u.rao>>02555000
   filebufxtrandel = 251 ,  <<extraneous parm to buf>>         <<u.rao>>02560000
   filefcoderedund = 252 ,  <<file code overrides previous>>   <<u.rao>>02565000
   fileunkfcode    = 253 ,  <<unknown file code>>              <<u.rao>>02570000
   filefcodevalue  = 254 ,  <<file code must be a positive int><<u.rao>>02575000
   filecodextrndel = 255 ,  <<extraneous parm to code>>        <<u.rao>>02580000
   filedevoverride = 256 ,  <<overrides previous dev>>         <<u.rao>>02585000
   filesysdefdev   = 257 ,  <<sysdef file dev forced>>         <<u.rao>>02590000
   filedsname2long = 259 ,  <<ds name > 8 characters>>         <<u.rao>>02595000
   filedevname2lng = 260 ,  <<device name > 8 characters>>     <<u.rao>>02600000
   fileoutprinot   = 261 ,  <<outpri legal only for output files>>      02605000
   fileoutpriinvld = 262 ,  <<unacceptable outpri>>            <<u.rao>>02610000
   filenumcopinvld = 263 ,  <<unacceptable number of copies>>  <<u.rao>>02615000
   filedevxparms   = 264 ,  <<unknown subparameter>>           <<u.rao>>02620000
   filediscoveride = 265 ,  <<override previous disc parm>>    <<u.rao>>02625000
   filefilesize    = 266 ,  <<illegal number of records>>      <<u.rao>>02630000
   fileextentsprob = 267 ,  <<illegal number of extents>>      <<u.rao>>02635000
   fileinitallocbd = 268 ,  <<unacceptable init allocation>>   <<u.rao>>02640000
   filediscxparms  = 269 ,  <<unknown disc subparameter>>      <<u.rao>>02645000
   filerecoverride = 270 ,  <<override previous rec =  >>      <<u.rao>>02650000
   filebadrecsize  = 271 ,  <<disallow recsize of 0>>          <<u.rao>>02655000
   filebadblocking = 272 ,  <<illegal block factor>>           <<u.rao>>02660000
   fileunkrecfmt   = 273 ,  <<unknown record format>>          <<u.rao>>02665000
   fileasciiinvald = 274 ,  <<neither ascii nor binary>>       <<u.rao>>02670000
   filerecxtranprm = 275 ,  <<unknown parm to rec parm>>       <<u.rao>>02675000
   feqtabfullxplct = 276 ,  <<file equate table full>>         <<u.rao>>02680000
   blddomainnot    = 277 ,  <<domain not allowed on build>>    <<u.rao>>02685000
   bldnotades      = 278 ,  <<actual designator not allowed on build>>  02690000
   bldfailed       = 279 ,  <<build of file failed>>           <<u.rao>>02695000
   filexpinvmonth  = 280 ,  <<bad no. for month>>              <<u.rao>>02700000
   filexpnoslashmd = 281 ,  <<no slash between month & day>>   <<u.rao>>02705000
   filexpinvday    = 282 ,  <<invalid no. for day of month>>   <<u.rao>>02710000
   filexpdayzero   = 283 ,  <<00 for month, not for day>>      <<u.rao>>02715000
   filexpnoslashdy = 284 ,  <<no slash between day & year>>    <<u.rao>>02720000
   filexpnonzero   = 285 ,  <<if month, day = 00, not year>>   <<u.rao>>02725000
   filexpxtrndata  = 286 ,  <<extraneous parm to exp date>>    <<u.rao>>02730000
   fileredundlabel = 287 ,  <<label redundantly specified>>    <<u.rao>>02735000
   filevolid2long  = 288 ,  <<volid > 6 characters>>           <<u.rao>>02740000
   filevolidspecal = 289 ,  <<embedded special in volid>>      <<u.rao>>02745000
   fileinvvoltype  = 290 ,  <<bad volume type>>                <<u.rao>>02750000
   filexpinvseq    = 291 ,  <<invalid sequence field>>         <<u.rao>>02755000
   filextrnlabel   = 292 ,  <<extraneous parm to label>>       <<u.rao>>02760000
   fileformoverrid = 293 ,  <<redundantly specified forms msg>><<u.rao>>02765000
   filefmsnoperiod = 294 ,  <<no period on forms message>>     <<u.rao>>02770000
   filefmstoolong  = 295 ,  <<truncated to 49 characters>>     <<u.rao>>02775000
   filelabelnolabel= 296 ,  <<label overriden by nolabel>>     <<u.rao>>02780000
   filenolocklock  = 297 ,  <<nolock overrides lock>>          <<u.rao>>02785000
   filelocknolock  = 298 ,  <<lock overrides nolock>>          <<u.rao>>02790000
   bldunknownkey   = 299 ,  <<unknown keyword to build>>       <<u.rao>>02795000
   bldnosysfiles   = 300,  <<only $newpass to :build>>         <<u.rao>>02800000
   fileinvaldevname= 301,  <<invalid dev name>>                <<00579>>02805000
   circularfeq     = 304,  <<circular file equations>>         <<00834>>02810000
   fileadessys     = 305,  <<environment not sysfile>>         <<01549>>02815000
   fileenvoverride = 306,  <<override previous env parameter>> <<01549>>02820000
   fileenvxparms   = 307,  <<env has no subparameters>>        <<01549>>02825000
   fileoutqoverride= 308,  <<override previous outq parm>>     <<01549>>02830000
   outqnamealphnum = 309,  <<outq name not alphanumeric>>      <<01549>>02835000
   outqname2lng    = 310,  <<outq name > 8 characters>>        <<01549>>02840000
   outqnamenotalph = 311,  <<outq name begins with alpha>>     <<01549>>02845000
   fileoutqxparms  = 312,  <<outq has no subparameters>>       <<01549>>02850000
   filesharesemi   = 313,  <<semi overrides shr>>              <<01549>>02855000
   fileexclsemi    = 314,  <<semi overrides exc>>              <<01549>>02860000
   filenocopycopy  = 315,  <<copy overrides nocopy>>           <<01549>>02865000
   filecopynocopy  = 316,  <<nocopy overrides copy>>           <<01549>>02870000
   filenomultgmult = 317,  <<gmulti overrides nomulti>>        <<01549>>02875000
   filemultigmulti = 318,  <<gmulti overrides multi>>          <<01549>>02880000
   filegmultimulti = 319,  <<multi overrides gmulti>>          <<01549>>02885000
   filegmultnomult = 320,  <<nomulti overrides gmulti>>        <<01549>>02890000
   fileriostd      = 321,  <<std overrides rio>>               <<01549>>02895000
   filemsgstd      = 322,  <<std overrides msg>>               <<01549>>02900000
   filecirstd      = 323,  <<std overrides cir>>               <<01549>>02905000
   filestdrio      = 324,  <<rio overrides std>>               <<01549>>02910000
   filemsgrio      = 325,  <<rio overrides msg>>               <<01549>>02915000
   filecirrio      = 326,  <<rio overrides cir>>               <<01549>>02920000
   filestdmsg      = 327,  <<msg overrides std>>               <<01549>>02925000
   fileriomsg      = 328,  <<msg overrides rio>>               <<01549>>02930000
   filecirmsg      = 329,  <<msg overrides cir>>               <<01549>>02935000
   filestdcir      = 330,  <<cir overrides std>>               <<01549>>02940000
   fileriocir      = 331,  <<cir overrides rio>>               <<01549>>02945000
   filemsgcir      = 332,  <<cir overrides msg>>               <<01549>>02950000
   filecontenv     = 333,  <<back ref. file contains env.>>    <<02554>>02955000
   filedensoverrid = 334,  <<override previous dens parm>>     <<02569>>02960000
   filedensxparm   = 335,  <<extraneous parm to dens>>         <<02569>>02965000
   filedensinval   = 336,  <<dens parm not valid>>             <<02569>>02970000
   filemissquote   = 337,  << missing quote on volid >>        <<02663>>02975000
   filenonprintchar= 338,  << volid has non print chars >>     <<02663>>02980000
   filecommaseminok= 339,  << volid can't have comma,semi >>   <<02663>>02985000
   filevirtualdev  = 342,  << virtual device not allowed >>    <<04171>>02990000
   fileinvldclaspec= 343,  << invalid device class >>          <<04171>>02995000
   fileunknowndev  = 344,  << unknown device class >>          <<04171>>03000000
   filedontknowldev= 345,  << unknown logical device >>        <<04171>>03005000
                                                                        03010000
<< secure command>>                                            <<u.rao>>03015000
   notcreator      = 351,  <<not creator of file>>             <<u.rao>>03020000
   discioerr       = 353, <<disc io error when accessing file l<<u.rao>>03025000
   secure2mp       = 354, <<only file name allowed>>           <<u.rao>>03030000
   securenotenuf   = 355, <<requires an actual file designator><<u.rao>>03035000
   getflabopen     = 356,  <<open failed in getflabel>>        <<04.ro>>03040000
<< reset and creset commands>>                                 <<u.rao>>03045000
   resetparmerr    = 360,                                      <<u.rao>>03050000
   cresetparmerr   = 361,                                      <<u.rao>>03055000
   feqnotfound     = 362, <<file equate not found>>            <<u.rao>>03060000
<< rename command>>                                            <<u.rao>>03065000
   rename2mp       = 370,                                      <<u.rao>>03070000
   renameexpecttemp= 371,                                      <<u.rao>>03075000
   renameoldffserr = 372,  <<rename old file error>>           <<u.rao>>03080000
   renamefailed    = 373,  <<call to frename failed>>          <<u.rao>>03085000
   renameclsfailed = 374,  <<close of renamed file failed>>    <<u.rao>>03090000
   renamereqoldname= 375  ,  <<expected old file name>>        <<u.rao>>03095000
   renamereqnewname= 376  ,  <<expected new file name>>        <<u.rao>>03100000
<< purge command>>                                             <<u.rao>>03105000
   purge2mp        = 380,                                      <<u.rao>>03110000
   purgereqfname   = 381,                                      <<u.rao>>03115000
   purgeexpecttemp = 382,                                      <<u.rao>>03120000
   purgefnotfound  = 383,                                      <<u.rao>>03125000
   purgefopenfaild = 384,  <<open of file to be purged failed>><<u.rao>>03130000
   purgeclosefaild = 385,  <<unable to purge file>>            <<u.rao>>03135000
   purgesemicolon  = 386  ,  <<found ";", expected ",">>       <<u.rao>>03140000
<< save command >>                                             <<u.rao>>03145000
   save2mp         = 390,                                      <<u.rao>>03150000
   savereqfname    = 391,                                      <<u.rao>>03155000
   saveexpectoldpass=392,                                      <<u.rao>>03160000
   saveopenoldpass = 393,  <<unable to open $oldpass>>         <<u.rao>>03165000
   saveclosoldpass = 394,  <<unable to close $oldpass>>        <<u.rao>>03170000
   savetempopen    = 395,  <<unable to open temp file>>        <<u.rao>>03175000
   savetempclose   = 396,  <<unable to save temp file>>        <<u.rao>>03180000
   savesemicolon   = 397  ,  <<found ";", expected ",">>       <<u.rao>>03185000
   savetempfail    = 398,   <<couldn't open stempfile>>        <<04784>>03190000
<< release command >>                                          <<u.rao>>03195000
   release2mp      = 400, <<only file name allowed>>           <<u.rao>>03200000
   releasenotenuf  = 401, <<requires an actual file designator><<u.rao>>03205000
<< altsec command >>                                           <<u.rao>>03210000
   altsecnotenuf   = 410, <<requires an actual file designator><<u.rao>>03215000
   altsec2mp       = 411, <<extraneous data on altsec command>><<u.rao>>03220000
<< listf command >>                                            <<u.rao>>03225000
   listfbadlevel    = 420, <<bad level # in listf>>            <<u.rao>>03230000
   listfsmcap       = 422, <<need sm capability>>              <<u.rao>>03235000
   listfamcap       = 423, <<need am capability>>              <<u.rao>>03240000
   listfexpectfile  = 424, <<expected file name>>              <<u.rao>>03245000
   listffserr       = 425, <<listf file sys error>>            <<u.rao>>03250000
   listfextraneous = 426,  <<unidentified fileset name>>       <<u.rao>>03255000
   listf2mp        = 427,  <<2 many parms to listf>>           <<u.rao>>03260000
   listfflabioerr  = 428,  <<io error reading file label>>     <<u.rao>>03265000
   listfhvsnotmtd  = 429,  <<home volume set not mounted>>     <<rv.pv>>03270000
   listfstopped    = 430,                                      <<03.km>>03275000
   noxxxlisted     = 431,                                      <<03.km>>03280000
   nofileslisted   = noxxxlisted,                              <<03.km>>03285000
<< file access mask errors (procedure formaccess, mostly)>>    <<u.rao>>03290000
   accessexpectlparen= 500, <<expected leading "(">>           <<u.rao>>03295000
   accessexpectrparen=501,<<expected trailing ")">>            <<u.rao>>03300000
   accessunknownfmode=502,<<expected file access mode type>>   <<u.rao>>03305000
   accessunknowngmode=503,<<ditto for group>>                  <<u.rao>>03310000
   accessunknownamode=504,<<ditto for account>>                <<u.rao>>03315000
   accessfsnotpermit=505, <<save not permitted for file>>      <<u.rao>>03320000
   accessasnotpermit=506, <<save not permitted for account>>   <<u.rao>>03325000
   accessexpectcolon=507, << (x:xx), didn't find colon>>       <<u.rao>>03330000
   accessunknownfuser=508,<<unknown file user type>>           <<u.rao>>03335000
   accessunknownguser=509,<<unknown group user type>>          <<u.rao>>03340000
   accessunknownauser=510,<<unknown account user type>>        <<u.rao>>03345000
   accesscrnotpermit=511, <<creator not permitted in group>>   <<u.rao>>03350000
   accessusnotpermit=512, <<not permitted at account level>>   <<u.rao>>03355000
   accessrredund   = 513, <<read redundantly specified>>       <<u.rao>>03360000
   accessaredund   = 514, <<append redundantly specified>>     <<u.rao>>03365000
   accesswredund   = 515, <<write  "               "   >>      <<u.rao>>03370000
   accesslredund   = 516, <<lock      "            "   >>      <<u.rao>>03375000
   accessxredund   = 517, <<execute   "            "   >>      <<u.rao>>03380000
   accesssredund   = 518, <<save      "            "   >>      <<u.rao>>03385000
   accessredundmode= 519, <<redundant in this list>>           <<u.rao>>03390000
<< file name errors>>                                          <<u.rao>>03395000
   fileexpectalpha = 530  ,                                    <<u.rao>>03400000
   ffnamebase=fileexpectalpha-1,                               <<u.rao>>03405000
   filenamemissing = 531  ,                                    <<u.rao>>03410000
   filenametoolong = 532  ,                                    <<u.rao>>03415000
   filemissingdelim= 535,                                     <<00.gen>>03420000
   filenogenname   = 536,                                     <<00.gen>>03425000
<< group name errors >>                                        <<u.rao>>03430000
   grpexpectalpha  = 540  ,                                    <<u.rao>>03435000
   fgnamebase=grpexpectalpha-1,                                <<u.rao>>03440000
<< account name errors >>                                      <<u.rao>>03445000
   acctexpectalpha = 550  ,                                    <<u.rao>>03450000
   fanamebase=acctexpectalpha-1,                               <<u.rao>>03455000
<< lockword name errors >>                                     <<u.rao>>03460000
   lwdexpectalpha  = 560  ,                                    <<u.rao>>03465000
   flwordbase=lwdexpectalpha-1,                                <<u.rao>>03470000
<< volume set definition name errors >>                        <<u.rao>>03475000
   vsdexpectalpha  = 570  ,                                    <<u.rao>>03480000
   vsdnamebase     = vsdexpectalpha-1,                         <<u.rao>>03485000
   vsdnolockword   = 579,                                     <<00.gen>>03490000
<< miscellaneous naming errors >>                              <<u.rao>>03495000
<< user name errors >>                                         <<u.rao>>03500000
   userexpectalpha = 590,                                      <<u.rao>>03505000
   usernamebase    = userexpectalpha-1,                        <<u.rao>>03510000
<< preprun, prep, run commands >>                              <<u.rao>>03515000
   errnoprogf      = 600  ,  <<no program file specified>>     <<u.rao>>03520000
   errnouslf       = 601  ,  <<no usl file specified>>         <<u.rao>>03525000
   errnoporuf      = 602  ,  <<neither specified>>             <<u.rao>>03530000
   errnopreptarget = 603  ,  <<no program file specified>>     <<u.rao>>03535000
   cmaxpctsemiorcr = 604  ,  <<found comma, needed ; or cr>>   <<u.rao>>03540000
   eqxpctsemiorcr  = 605  ,  <<found =, needed ; or cr>>       <<u.rao>>03545000
   extrndelimignrd = 606  ,  <<ignored extraneous delimiter>>  <<u.rao>>03550000
   contxtrunnotprp = 607  ,  <<allowed in run, not prep>>      <<u.rao>>03555000
   contxtprpnotrun = 608  ,  <<allowed in prep, not run>>      <<u.rao>>03560000
   unknownkeyprep  = 609  ,                                    <<u.rao>>03565000
   unknownkeyrun   = 610  ,                                    <<u.rao>>03570000
   unknownkeyprprn = 611  ,                                    <<u.rao>>03575000
   reqequalsign    = 612  ,  <<need equals sign>>              <<u.rao>>03580000
   invalidlib      = 613  ,  <<need one of s,p, or g>>         <<u.rao>>03585000
   invalidmaxdata  = 614  ,                                    <<u.rao>>03590000
   invalidparm     = 615  ,                                    <<u.rao>>03595000
   invalidstaksize = 616  ,                                    <<u.rao>>03600000
   invaliddlsize   = 617  ,                                    <<u.rao>>03605000
   missingcap      = 618  ,  <<a syntax problem with capability<<u.rao>>03610000
   unknowncap      = 619  ,  <<not recognized capability>>     <<u.rao>>03615000
   warnduplkey     = 620  ,  <<a warning only>>                <<u.rao>>03620000
   segmentererror  = 621  ,  <<segmenter return to cxpreprun>> <<u.rao>>03625000
   nosuchprogfile  = 622  ,  <<the create failed.>>            <<u.rao>>03630000
   defval          = 623,  <<default maxdata taken>>           <<u.rao>>03635000
   prprnnoload     = 625,  <<unable to load program>>          <<u.rao>>03640000
   invalidprogfile = 626,   <<invalid program file>>           <<u.rao>>03645000
   errentrytoobig  = 627,  <<entry point name > 15 char long>> <<u.rao>>03650000
   invalidpatch    = 628,                                      <<00629>>03655000
<< other subsystem errors (basic, spl, rje, etc. >>            <<u.rao>>03660000
   err2mplistonly  = 640,                                      <<u.rao>>03665000
   subsnotfound    = 641,                                      <<u.rao>>03670000
   subs2mp         = 642,                                      <<u.rao>>03675000
   compfailednoprp = 643,                                      <<u.rao>>03680000
   prepfailednorun = 644,                                      <<u.rao>>03685000
   basiccreateerr  = 648,  <<unable to create basic interp.>>  <<u.rao>>03690000
   basicloaderr    = 649,  <<unable to load basic interpreter>><<u.rao>>03695000
   subsyscreateerr = 650,  <<unable to create subsystem>>      <<u.rao>>03700000
   subsysloaderr   = 651,  <<unable to load subsystem>>        <<u.rao>>03705000
   compiledcreate  = 654,  <<unable to create user prog>>      <<u.rao>>03710000
   compiledload    = 655,   <<unable to load user prog>>       <<u.rao>>03715000
   feqtabfull      = 656,  <<file equate table full>>          <<u.rao>>03720000
   toomanyfeqbref  = 657,  <<too many back ref's>>             <<u.rao>>03725000
   aplxpctjustws   = 659,  <<too many parms to apl command>>   <<02.ro>>03730000
   subsnotcreate   = 660,  <<createprocess failed on subsys.>> <<01452>>03735000
   infooveride     = 661,  <<multiple info parms >>            <<02844>>03740000
   unknwnkwrd      = 662,  << unknown keyword >>               <<02844>>03745000
   wkspalreadyfnd  = 663,  << wksp specified more than once >> <<06130>>03750000
<< additional errors for :run command >>                       <<01200>>03755000
   invalidstdin    = 680,  <<incorrect stdin specification>>   <<01200>>03760000
   invalidstdlist  = 681,  <<incorrect stdlist specification>> <<01200>>03765000
   EXPCTQUOTE      = 682,  <<EXPECTED ' OR " TO START STRING>> <<01200>>03770000
   EXPCTCLOSEQUOTE = 683,  <<EXPECTED ' OR " TO END STRING>>   <<01200>>03775000
                           << to trap internal problems.>>     <<01452>>03780000
   xpctsemiorcr    = 687,  <<expected ; or cr>>                <<01709>>03785000
   stringtoobig    = 688,  <<info string > 255 chars>>         <<01709>>03790000
   invalidsysdeffl = 689, <<invalid system defined file >>     <<02324>>03795000
   impiaba         = 690,                                      <<02369>>03800000
   bothfpmapnofpmap= 691, <<both fpmap/nofpmap specified>>     <<04103>>03805000
<<organizational management command error messages>>           <<u.rao>>03810000
   errabterm       = 976, <<abnormal program termination>>     <<u.rao>>03815000
   reqformalfdesig = 984,                                      <<u.rao>>03820000
   pgmabort        = 989,  <<program aborted by user>>         <<u.rao>>03825000
<< 1000's reserved for store/restore >>                        <<u.rao>>03830000
<< 1100's reserved for private volumes messages >>             <<u.rao>>03835000
   <<1126-1135 reserved for implicitmnt errors>>               <<03.km>>03840000
   im'mnterr       = 1126,   <<mount error recorded in dst>>   <<03.km>>03845000
<< 1200's reserved for user logging >>                         <<u.rao>>03850000
<< 1300's reserved for ds >>                                   <<u.rao>>03855000
<< 1400's reserved for startdevice (hello, job, data)>>        <<u.rao>>03860000
<< 1500 - 1529 reserved for showjob >>                         <<u.rao>>03865000
<< 1530 - 1579 reserved for showin and showout >>              <<u.rao>>03870000
<< 1580 - 1589 reserved for showdev >>                         <<u.rao>>03875000
<< 1590 - 1609 reserved for stream >>                          <<u.rao>>03880000
<< tell command >>                                             <<u.rao>>03885000
<< showq command >>                                            <<u.rao>>03890000
   warnxparmsignored=1670, <<command has no parms, parms ignore<<u.rao>>03895000
<< setmsg command >>                                           <<u.rao>>03900000
   setmsgparmprob  = 1675, <<missing or unknown parm>>         <<u.rao>>03905000
   setmsgextraparm = 1676, <<too many parms to setmsg>>        <<u.rao>>03910000
<< setdump command >>                                          <<u.rao>>03915000
   setdumpunknown  = 1680, <<unknown option to setdump>>       <<u.rao>>03920000
   setdump2mp      = 1681, <<more than 4 parms to setdump>>    <<u.rao>>03925000
<< cline command >>                                            <<u.rao>>03930000
   errlnotfound    = 1764, <<cline equation not found>>        <<u.rao>>03935000
<< 1900 - 1999 reserved for user defined commands (udc) >>     <<09.eb>>03940000
<< 3000-4000 are reserved for operator commands>>              <<00552>>03945000
                                                               <<00552>>03950000
<< iml/3000 error messages >>                                  <<02845>>03955000
   toomanyparms    = 3820, << too many parms for iml cmnd >>   <<02845>>03960000
   expectsemic     = 3821, << expect semicolon delim >>        <<02845>>03965000
   unknownkey      = 3822, << invalid keyword >>               <<02845>>03970000
   redndenh        = 3823, << enhance redundantly specd. >>    <<02845>>03975000
   expctequal      = 3824, << expected equal as delmiter >>    <<02845>>03980000
   illvalenh       = 3825, << illegal value for enhance >>     <<02845>>03985000
   redndfmt        = 3826, << format redundantly specd. >>     <<02845>>03990000
   illvalfmt       = 3827, << illegal value for format >>      <<02845>>03995000
   redndpri        = 3828, << pri. redundantly specd. >>       <<02845>>04000000
   illvalpri       = 3829, << illegal value for pri. >>        <<02845>>04005000
<< set command error messages >>                               <<04786>>04010000
   nonalpha        = 4400, << expects alphanumeric parm >>     <<04786>>04015000
   invalid'parm    = 4401, << invalid parameter         >>     <<04786>>04020000
   no'equals       = 4402, << expected an equal sign    >>     <<04786>>04025000
   bad'option      = 4403, << unknown option given      >>     <<04786>>04030000
   already         = 4404, << option already in effect  >>     <<04786>>04035000
   not'spooled     = 4405, << $stdlist not spooled      >>     <<04786>>04040000
   unexp'delim     = 4406, << extraneous characters     >>     <<04786>>04045000
<< listeq and listftemp error messages >>                      << 8499>>04050000
                                                               <<04786>>04055000
   leq'no'feqs     = 3282, << no feq found              >>     << 8499>>04060000
   leq'feqs        = 3283, << the heading               >>     << 8499>>04065000
listftempnotfeqs       = 3284,                                 << 8500>>04070000
listftempbadlevel      = 3285,                                 << 8500>>04075000
listftempsmoram        = 3286,                                 << 8500>>04080000
listftempexpectfile    = 3287,                                 << 8500>>04085000
listftemp2mp           = 3288,                                 << 8500>>04090000
listftemp'pv'not'mnted = 1,                                    << 8921>>04095000
listftemp'file'gone    = 2,                                    << 8921>>04100000
listftempnotfound      = 3289,                                 << 8500>>04105000
      <<file system definitions >>                                      04110000
                                                                        04115000
      file'secure = 22,                                        << 8500>>04120000
      flsecmatrix=10,                                                   04125000
                                                                        04130000
                                                               <<00851>>04135000
      <<definitions for finding the plabel for showcom>>                04140000
                                                                        04145000
      << fcontrol definitions >>                               <<00851>>04150000
                                                               <<00851>>04155000
      timeout      = 4,                                        <<00851>>04160000
      disablebreak = 14,                                       <<00851>>04165000
      enablebreak  = 15,                                       <<00851>>04170000
                                                                        04175000
      <<sirs used throughout>>                                          04180000
                                                                        04185000
     filesir=37,                                                        04190000
                                                                        04195000
      <<words/flags>>                                                   04200000
                                                                        04205000
      coldloadid=%1075,                                                 04210000
      pxgwjit = 6;                                             <<06568>>04215000
$include inclpcb5                                              <<06568>>04220000
logical pointer pcb = syspcbindex;                             <<06568>>04225000
      <<defines used throughout>>                                       04230000
                                                                        04235000
      <<code definitions>>                                              04240000
                                                                        04245000
      define                                                            04250000
      cc = status . (6:2)#,                                             04255000
      lbparmdecs=array lparm (*) = parms;                               04260000
                 byte array bparm (*) = parms #,                        04265000
      nextline=assemble (zero,dzro);                           <<01881>>04270000
               print (*, *, *)#,                               <<01881>>04275000
                                                               <<01709>>04280000
<<        def'movefromdseg          >>                         <<u.rao>>04285000
<< to use, declare subroutine def'movefromdseg >>              <<u.rao>>04290000
   def'movefromdseg =                                          <<u.rao>>04295000
      movefromdseg(target,dstn,offset,count);                  <<u.rao>>04300000
         value target,dstn,offset,count;                       <<u.rao>>04305000
         logical target,dstn,offset,count;                     <<u.rao>>04310000
      begin                                                    <<u.rao>>04315000
         x := tos; << save return address >>                   <<u.rao>>04320000
         assemble(mfds 0);                                     <<u.rao>>04325000
         tos := x; << restore return address >>                <<u.rao>>04330000
      end #,                                                   <<u.rao>>04335000
                                                               <<u.rao>>04340000
<<        def'movetodseg            >>                         <<u.rao>>04345000
<< to use, declare subroutine def'movetodseg >>                <<u.rao>>04350000
   def'movetodseg =                                            <<u.rao>>04355000
      movetodseg(dstn,offset,source,count);                    <<u.rao>>04360000
         value dstn,offset,source,count;                       <<u.rao>>04365000
         logical dstn,offset,source,count;                     <<u.rao>>04370000
      begin                                                    <<u.rao>>04375000
         x := tos;                                             <<u.rao>>04380000
         assemble(mtds 0);                                     <<u.rao>>04385000
         tos := x;                                             <<u.rao>>04390000
      end #,                                                   <<u.rao>>04395000
                                                               <<u.rao>>04400000
                                                                        04405000
      << fields/flags>>                                                 04410000
                                                                        04415000
                                                               <<02.ro>>04420000
<<delimiter array declarations>>                               <<u.rao>>04425000
                                                               <<u.rao>>04430000
semicr  = [8/";",8/%15]#,                                      <<u.rao>>04435000
commasemicr = [8/",",8/";",8/%15,8/0]d#,                       <<u.rao>>04440000
                                                               <<u.rao>>04445000
      <<executor procedure heading>>                                    04450000
                                                                        04455000
      executorhead =                                                    04460000
      (parmsp,errnum,parmnum);                                          04465000
      byte array parmsp;                                                04470000
      integer errnum,parmnum#;                                 <<06567>>04475000
                                                               << 8765>>04480000
<< dst data segment pointer and definitions >>                 << 8765>>04485000
                                                               << 8765>>04490000
logical pointer dst = 2;                                       << 8765>>04495000
                                                               << 8765>>04500000
equate  dst'entry'size = 4;                                    << 8765>>04505000
                                                               << 8765>>04510000
define  dst'dseg'size  = (3:13)#;                              << 8765>>04515000
                                                                        04520000
                                                                        04525000
equate   wsidtoolong        =   4431,                          <<06842>>04530000
         badwsid            =   4432,                          <<06842>>04535000
         wsidnotconf        =   4433,                          <<06842>>04540000
         nrjenotfound       =   4434,                          <<06842>>04545000
         badconfaccess      =   4435;                          <<06842>>04550000
                                                               <<06842>>04555000
                                                              <<00.gen>>04560000
                                                              <<00.gen>>04565000
<<  p r o d u c e p a r m s   d e f i n i t i o n s  >>       <<00.gen>>04570000
                                                              <<00.gen>>04575000
define d'inx=      dppresult #,        <<"PPRESULT" fmt>>     <<00.gen>>04580000
       d'inx1=     ppresult #,                                <<00.gen>>04585000
       d'inx2=     ppresult(1) #,                             <<04.gen>>04590000
       d'type=     ppresult(2) #,                             <<00.gen>>04595000
       d'fname=    ppresult(3) #,                             <<00.gen>>04600000
       d'gname=    ppresult(7) #,                             <<00.gen>>04605000
       d'aname=    ppresult(11) #,                            <<00.gen>>04610000
       d'lockword= ppresult(15) #,                            <<00.gen>>04615000
       g'fname=    ppresult(19) #,                            <<00.gen>>04620000
       g'gname=    ppresult(23) #,                            <<00.gen>>04625000
       g'aname=    ppresult(27) #;                             << i.a >>04630000
                                                               <<01.pv>>04635000
                                                               <<01.pv>>04640000
<<  d i r e c t o r y   e n t r y   d e f i n i t i o n s  >>  <<01.pv>>04645000
equate                                                         <<01.pv>>04650000
   namesize        = 4,                  <<unpacked rep>>      <<01.pv>>04655000
                   <<entry equates>>                           <<01.pv>>04660000
                                                               <<01.pv>>04665000
                                                               <<01.pv>>04670000
<< account entry >>                                            <<01.pv>>04675000
   aname           = 0,                  <<name>>              <<01.pv>>04680000
   agipntr         = aname+namesize,     <<group index pntr>>  <<01.pv>>04685000
   auipntr         = agipntr+1,          <<user index pntr>>   <<01.pv>>04690000
   acap            = auipntr+1,          <<capability>>        <<01.pv>>04695000
   alattr          = acap+2,                                   <<01.pv>>04700000
   apass           = alattr+2,                                 <<01.pv>>04705000
   adfscount       = apass+namesize,     <<disc file space>>   <<01.pv>>04710000
   adfslimit       = adfscount+2,                              <<01.pv>>04715000
   acpucount       = adfslimit+2,        <<cpu time>>          <<01.pv>>04720000
   acpulimit       = acpucount+2,                              <<01.pv>>04725000
   acontimecount   = acpulimit+2,        <<connect time>>      <<01.pv>>04730000
   acontimelimit   = acontimecount+2,                          <<01.pv>>04735000
   asecw           = acontimelimit+2,                          <<01.pv>>04740000
   amaxjobw        = asecw+1,            <<max. job priority>> <<01.pv>>04745000
   aspare1         = amaxjobw+1,                               <<rv.pv>>04750000
   aspare2         = aspare1 +1,                               <<rv.pv>>04755000
   asize           = aspare2 +1,                               <<rv.pv>>04760000
                                                               <<01.pv>>04765000
<<group entry>>                                                <<01.pv>>04770000
   gname           = 0,                  <<name>>              <<01.pv>>04775000
   gfipntr         = gname+namesize,     <<file index>>        <<01.pv>>04780000
   gpass           = gfipntr+1,          <<password>>          <<01.pv>>04785000
   gdfscount       = gpass+namesize,     <<disc file space>>   <<01.pv>>04790000
   gdfslimit       = gdfscount+2,                              <<01.pv>>04795000
   gcpucount       = gdfslimit+2,        <<cpu time>>          <<01.pv>>04800000
   gcpulimit       = gcpucount+2,                              <<01.pv>>04805000
   gcontimecount   = gcpulimit+2,                              <<01.pv>>04810000
   gcontimelimit   = gcontimecount+2,                          <<01.pv>>04815000
   gsec            = gcontimelimit+2,                          <<01.pv>>04820000
   gcap            = gsec +2,                                  <<01.pv>>04825000
   glinkage        = gcap+1,                                   <<01.pv>>04830000
   gvsdipntr       = glinkage+1,         <<vs def index pntr>> <<01.pv>>04835000
   ghvsname        = gvsdipntr+1,        <<home vs name>>      <<01.pv>>04840000
   ghvsaname       = ghvsname,           << "   "  acct name>> <<01.pv>>04845000
   ghvsgname       = ghvsaname+namesize, << "   "  grp  name>> <<01.pv>>04850000
   ghvsvsname      = ghvsgname+namesize, << "   "  vs   name>> <<01.pv>>04855000
   gsavefipntr     = ghvsvsname+namesize,                      <<13.pv>>04860000
   gmountrefcntr   = gsavefipntr+1,                            <<13.pv>>04865000
   gspare          = gmountrefcntr+1,                          <<13.pv>>04870000
   gsize           = gspare +1;                                <<01.pv>>04875000
<<glinkage definitions>>                                       <<01.pv>>04880000
define                                                         <<01.pv>>04885000
   pvf             = 0:1 #,                                    <<01.pv>>04890000
   mvtabxf         = 8:8 #;                                    <<01.pv>>04895000
define                                                         <<10.km>>04900000
   pvmvtabxf= 4:4 #;                   <<pvinfo field>>        <<10.km>>04905000
equate                                                         <<01.pv>>04910000
<<entry types>>                                                <<01.pv>>04915000
   grouplevel      = 1,                                        <<01.pv>>04920000
   accountlevel    = 2,                                        <<01.pv>>04925000
   userlevel       = 3,                                        <<01.pv>>04930000
   vsdeflevel      = 4;                                        <<rv.pv>>04935000
                                                               <<01.pv>>04940000
<<directory search type word definitions>>                     <<01.pv>>04945000
define                                                         <<01.pv>>04950000
   startlevelf     = 13:3 #,                                   <<01.pv>>04955000
   allflag         =  9:1 #,                                   <<01.pv>>04960000
   endlevelfx      =  9:4 #,                                   <<01.pv>>04965000
   tolevelf        =  6:3 #,                                   <<01.pv>>04970000
   hitflag         =  5:1 #;                                   <<01.pv>>04975000
equate                                                         <<01.pv>>04980000
   allxxx          = %(2)1000,                                 <<04.pv>>04985000
   allaccts        = allxxx + accountlevel,                    <<04.pv>>04990000
   allgroups       = allxxx + grouplevel,                      <<04.pv>>04995000
   allusers        = allxxx + userlevel,                       <<04.pv>>05000000
   ppr'len         = 31 +    << "ppresult" size >>             <<04178>>05005000
                     asize+1+<< account entry size >>          <<04178>>05010000
                     gsize+1,<< group entry size   >>          <<04178>>05015000
   sysl'parmlen    = 35 + ppr'len,<< "syslist" parm >>         <<04178>>05020000
   sysl'pprinx     = sysl'parmlen - ppr'len,                   <<04178>>05025000
   savebuffindex = sysl'pprinx + 31;                           <<04178>>05030000
                                                               <<03.km>>05035000
<<directory search states (returned by recip)>>                <<03.km>>05040000
equate gotsir=          1,                                     <<03.km>>05045000
       nextson=         0,                                     <<03.km>>05050000
       nextbrother=     2,                                     <<03.km>>05055000
       nextuncle=       nextbrother,   <<not implemented>>     <<03.km>>05060000
       revisit=         %100000,                               <<03.km>>05065000
       abortscan=       4,                                     <<03.km>>05070000
       nextson'sir=     nextson+gotsir,                        <<03.km>>05075000
       nextbrother'sir= nextbrother+gotsir,                    <<03.km>>05080000
       nextuncle'sir=   nextuncle+gotsir,                      <<03.km>>05085000
       abortscan'sir=   abortscan+gotsir;                      << i.a >>05090000
$include incljdt                                               << 8499>>05095000
$page   "EXTERNAL DECLARATIONS"                                         05100000
                                                               << i.a >>05105000
<< external/forward mpe intrinsics >>                          << i.a >>05110000
                                                               << i.a >>05115000
   procedure date'line(string);                                <<0u.eb>>05120000
      byte array string; option external;                      <<0u.eb>>05125000
                                                               <<0u.eb>>05130000
                                                               <<00.eb>>05135000
intrinsic setjcw,getjcw,fcontrol;                              <<00851>>05140000
   logical procedure binary (string, length);                           05145000
   value length;                                                        05150000
   byte array string;                                                   05155000
   integer length;                                                      05160000
   option external;                                                     05165000
                                                                        05170000
   integer procedure exchangedb(dstno);                                 05175000
   value dstno;                                                         05180000
   integer dstno;                                                       05185000
   option external;                                                     05190000
                                                                        05195000
   double procedure dbinary(string,length);                             05200000
   value length;                                                        05205000
   byte array string;  integer length;                                  05210000
   option external;                                                     05215000
                                                                        05220000
   integer procedure ascii (word, base, string);                        05225000
   value word, base;                                                    05230000
   logical word;                                                        05235000
   integer base;                                                        05240000
   byte array string;                                                   05245000
   option external;                                                     05250000
                                                                        05255000
   integer procedure dascii(word,base,string);                          05260000
   value word,base;                                                     05265000
   double word;                                                         05270000
   integer base;                                                        05275000
   byte array string;                                                   05280000
   option external;                                                     05285000
                                                                        05290000
   procedure print (string, length, type);                              05295000
   value length, type;                                                  05300000
   array string;                                                        05305000
   integer length;                                                      05310000
   logical type;                                                        05315000
   option external;                                                     05320000
                                                                        05325000
   integer procedure search (target, length, dict, defn);               05330000
   value length;                                                        05335000
   byte array target, dict;                                             05340000
   integer length;                                                      05345000
   byte pointer defn;                                                   05350000
   option external, variable;                                           05355000
                                                               <<01.01>>05360000
   integer procedure mycommand                                          05365000
   (comimage,delims,maxparms,numparms,parms,dict,defn);                 05370000
   value maxparms;                                                      05375000
   byte array comimage,delims,dict;                                     05380000
   integer maxparms, numparms;                                          05385000
   double array parms;                                                  05390000
   byte pointer defn;                                                   05395000
   option variable,external;                                            05400000
                                                                        05405000
   procedure who(mode,cap,lattr,usern,groupn,acctn,homen,termnum);      05410000
   logical mode;                                                        05415000
   double cap,lattr;                                                    05420000
   byte array usern,groupn,acctn,homen;                                 05425000
   logical termnum;                                                     05430000
   option variable,external;                                            05435000
                                                                        05440000
   logical procedure parse'density(parm,parmlen,den'value);    <<02569>>05445000
   value parmlen;                                              <<02569>>05450000
   integer den'value,parmlen;                                  <<02569>>05455000
   byte array parm;                                            <<02569>>05460000
   option external;                                            <<02569>>05465000
                                                               <<02569>>05470000
   integer procedure fopen (filedesignator,foptions, aoptions, recsize, 05475000
   device, formmsg, recmode, blockfactor, numbuffers, filesize,         05480000
   numextents, initalloc, filecode);                                    05485000
   value foptions, aoptions, recsize, recmode, blockfactor, numbuffers, 05490000
   filesize, numextents, initalloc, filecode;                           05495000
   byte array filedesignator,  device, formmsg;                         05500000
   logical foptions, aoptions;                                          05505000
   integer recsize, recmode, blockfactor, numbuffers, numextents,       05510000
   initalloc, filecode;                                                 05515000
   double filesize;                                                     05520000
   option variable, external;                                           05525000
                                                               <<00098>>05530000
   integer procedure dfopen                                    <<00200>>05535000
     (fname,fops,aops,recsize,dev,formmsg,numlabs,blkfact,     <<00200>>05540000
      numbufs,fsize,numexts,initexts,fcode);                   <<00200>>05545000
     value fops,aops,recsize,numlabs,blkfact,numbufs,fsize,    <<00200>>05550000
           numexts,initexts,fcode;                             <<00200>>05555000
     byte array fname,dev,formmsg;                             <<00200>>05560000
     logical fops,aops;                                        <<00200>>05565000
     integer recsize,numlabs,blkfact,numbufs,numexts,initexts, <<00200>>05570000
             fcode;                                            <<00200>>05575000
     double fsize; option variable,external;                   <<00200>>05580000
                                                                        05585000
   procedure fclose (filenum, disposition, seccode);                    05590000
   value filenum, disposition, seccode;                                 05595000
   integer filenum, disposition, seccode;                               05600000
   option external;                                                     05605000
                                                                        05610000
   integer procedure fread (fnum, buf, count);                          05615000
      value fnum, count;                                                05620000
      integer fnum, count;                                              05625000
      array buf;                                                        05630000
      option external;                                                  05635000
                                                                        05640000
   procedure fwrite(fnum,target,count,cont);                            05645000
   value fnum,count,cont;                                               05650000
   integer fnum,count,cont;                                             05655000
   array target;                                                        05660000
   option external;                                                     05665000
                                                                        05670000
   procedure fcheck(filenum,errorcode,tlog,blknum,numrecs);             05675000
   value filenum;                                                       05680000
   integer filenum,errorcode,tlog,numrecs;                              05685000
   double blknum;                                                       05690000
   option variable,external;                                            05695000
                                                                        05700000
   procedure fgetinfo                                                   05705000
   (fnum,filename,foptions,aoptions,recsize,devtype,ldnum,hdaddr,       05710000
    filecode,recptr,eof,limit,logcount,physcount,blksize,extsize,       05715000
    numextents,userlabels,creatorid,labaddr);                           05720000
   value fnum;                                                          05725000
   integer fnum,recsize,devtype,filecode,blksize,numextents,userlabels; 05730000
   byte array filename,creatorid;                                       05735000
   logical foptions,aoptions,ldnum,hdaddr,extsize;                      05740000
   double recptr,eof,limit,logcount,physcount,labaddr;                  05745000
   option variable,external;                                            05750000
                                                                        05755000
integer procedure flabio (ldev,addr,func,flab);                         05760000
    value   ldev,func,addr;                                             05765000
    integer ldev,func;                                                  05770000
    logical array flab;                                                 05775000
    double addr;                                                        05780000
    option external;                                                    05785000
                                                                        05790000
   procedure frename(filenum,fname);                                    05795000
   value filenum;                                                       05800000
   integer filenum;                                                     05805000
   byte array fname;                                                    05810000
   option external;                                                     05815000
                                                                        05820000
   procedure segmenter                                                  05825000
   (pin,command,error,num1,num2,num3,num4,num5,num6,           <<00629>>05830000
    str1,str2,fname1,fname2);                                  <<00629>>05835000
   value command,num1,num2,num3,num4,num5,num6;                <<00629>>05840000
   integer pin,command,error,num1,num2,num3,num4,num5,num6;    <<00629>>05845000
   byte array str1,str2,fname1,fname2;                                  05850000
   option variable, external;                                           05855000
                                                                        05860000
   procedure createprocess (error,pin,progname,optnums,opts);  <<01200>>05865000
   integer error,pin;                                          <<01200>>05870000
   byte array progname;                                        <<01200>>05875000
   integer array optnums;                                      <<01200>>05880000
   logical array opts;                                         <<01200>>05885000
   option variable, external;                                  <<01200>>05890000
                                                               <<01200>>05895000
   procedure create(progname,entryname,pin,parm,flags,                  05900000
   stack,dl,maxdata,pri,rank);                                          05905000
   value parm,stack,dl,pri,flags,maxdata,rank;                          05910000
   logical pin,parm,flags,pri;                                          05915000
   integer stack,dl,maxdata,rank;                                       05920000
   byte array progname, entryname;                                      05925000
   option external, variable;                                           05930000
                                                                        05935000
   procedure awake(pcbpt,n,wtflg);                                      05940000
   value pcbpt,n,wtflg;                                                 05945000
   integer pcbpt,n,wtflg;                                               05950000
   option external;                                                     05955000
                                                               <<02318>>05960000
logical procedure setcritical;                                 <<02318>>05965000
option external;                                               <<02318>>05970000
                                                                        05975000
   logical procedure calendar;                                          05980000
   option external;                                                     05985000
                                                                        05990000
   double procedure clock;                                              05995000
   option external;                                                     06000000
                                                                        06005000
   logical procedure getsir (n);                                        06010000
   value n;                                                             06015000
   logical n;                                                           06020000
   option external;                                                     06025000
                                                                        06030000
   procedure relsir (n,t);                                              06035000
   value n, t;                                                          06040000
   logical n, t;                                                        06045000
   option external;                                                     06050000
                                                                        06055000
   double procedure direcscan (type,linkage'indexp,aname,      <<38.pv>>06060000
                               guname,fname,recip,ldn,mvtabx); <<38.pv>>06065000
   value type,linkage'indexp,mvtabx;                           <<38.pv>>06070000
   integer type,mvtabx;                                        <<38.pv>>06075000
   double  linkage'indexp;                                     <<38.pv>>06080000
   array aname,guname,fname,ldn;                                        06085000
   integer procedure recip;                                             06090000
   option external,variable;                                   <<35.pv>>06095000
                                                                        06100000
   integer procedure addjtentry(n1,n2,n3,tno,size,info);                06105000
   value size,tno;                                                      06110000
   integer size,tno;                                                    06115000
   byte array n1,n2,n3;                                                 06120000
   integer array info;                                                  06125000
   option external;                                                     06130000
                                                                        06135000
   integer procedure xaddjtentry(n1,n2,n3,tno,size,info,xn1,xn2,xn3);   06140000
   value size,tno;                                                      06145000
   integer size,tno;                                                    06150000
   byte array n1,n2,n3,xn1,xn2,xn3;                                     06155000
   integer array info;                                                  06160000
   option external;                                                     06165000
                                                                        06170000
   integer procedure xremjtentry(n1,n2,n3,tno);                         06175000
   value tno;                                                           06180000
   integer tno;                                                         06185000
   byte array n1,n2,n3;                                                 06190000
   option external;                                                     06195000
                                                                        06200000
   logical procedure lockjir;                                           06205000
   option external;                                                     06210000
                                                                        06215000
   procedure unlockjir (a);                                             06220000
   value a;                                                             06225000
   integer a;                                                           06230000
   option external;                                                     06235000
                                                                        06240000
   double procedure attachio(ldev,qmisc,dstx,addr,func,cnt,p1,p2,flags);06245000
   value ldev,qmisc,dstx,addr,func,cnt,p1,p2,flags;                     06250000
   integer ldev,qmisc,dstx,addr,func,cnt,p1,p2,flags;                   06255000
   option external;                                                     06260000
                                                                        06265000
integer procedure genmsg(setno,msgno,mask,a,b,c,d,e,           <<0u.eb>>06270000
      dest,reply,buff,dst,iotype);                             <<0u.eb>>06275000
   value setno,msgno,mask,a,b,c,d,e,dest,reply,buff,           <<0u.eb>>06280000
      dst,iotype;                                              <<0u.eb>>06285000
   logical setno,msgno,mask,a,b,c,d,e,dest,reply,buff,         <<0u.eb>>06290000
      dst,iotype;                                              <<0u.eb>>06295000
   option variable,external;                                   <<0u.eb>>06300000
                                                               <<u.rao>>06305000
   procedure erroron;                                                   06310000
   option external;                                                     06315000
                                                                        06320000
   procedure errorexit(intrinexit,errbytes,param);                      06325000
   value intrinexit,errbytes,param;                                     06330000
   logical intrinexit,errbytes,param;                                   06335000
   option external;                                                     06340000
                                                                        06345000
integer procedure formname(type,target,ba1,ba2,ba3,ba4);       <<02.eb>>06350000
   value type; integer type;                                   <<02.eb>>06355000
   byte array target,ba1,ba2,ba3,ba4; option external;         <<02.eb>>06360000
                                                               <<02.eb>>06365000
integer procedure getdevinfo(device,devinfo);                  <<00579>>06370000
   byte array device;                                          <<00579>>06375000
   integer array devinfo;                                      <<00579>>06380000
   option privileged,uncallable,external;                      <<00579>>06385000
                                                               <<00579>>06390000
integer procedure get'dsdevice( ldev );                        <<02848>>06395000
   value   ldev;                                               <<02848>>06400000
   integer ldev;                                               <<02848>>06405000
   option  privileged, uncallable, external;                   <<02848>>06410000
                                                               <<02848>>06415000
procedure dismount (vsname,vsgroup,vsaccnt,reqtype,            <<00211>>06420000
                    mvtabx,some'other'pin);                    <<00211>>06425000
   value mvtabx,some'other'pin;                                <<00211>>06430000
   integer reqtype,mvtabx,some'other'pin;                      <<00211>>06435000
   byte array vsname,vsgroup,vsaccnt;                          <<rh.pv>>06440000
   option variable,external;                                   <<rh.pv>>06445000
                                                               <<rh.pv>>06450000
integer procedure lun (vtabinx,mvtabx);                        <<rv.pv>>06455000
    value   vtabinx,mvtabx;                                    <<rv.pv>>06460000
    integer vtabinx,mvtabx;                                    <<rv.pv>>06465000
    option external;                                           <<rv.pv>>06470000
                                                               <<rv.pv>>06475000
procedure initudc( show, comfn );                              <<03737>>06480000
   value    show, comfn;                                       <<03737>>06485000
   logical  show;                                              <<03737>>06490000
   integer  comfn;                                             <<03737>>06495000
   option   variable, external;                                <<03737>>06500000
procedure qualifyfilename(oldfname,newfname);                  <<03.eb>>06505000
   byte array oldfname,newfname; option external;              <<03.eb>>06510000
                                                               <<03.eb>>06515000
procedure crunch(n1,n2,n3,dest,nwords);                        <<02554>>06520000
   integer nwords;                                             <<02554>>06525000
   integer array dest;                                         <<02554>>06530000
   byte array n1,n2,n3;                                        <<02554>>06535000
   option external;                                            <<02554>>06540000
integer procedure xretjtentry(n1,n2,n3,size,info);             <<02554>>06545000
   byte array n1,n2,n3;                                        <<02554>>06550000
   integer size;                                               <<02554>>06555000
   integer array info;                                         <<02554>>06560000
   option external;                                            <<02554>>06565000
   integer procedure cyimplctfile'(lhs,rhs,lenr);              <<u.rao>>06570000
   value lenr;                                                 <<u.rao>>06575000
   integer lenr;                                               <<u.rao>>06580000
   byte array lhs, rhs;                                        <<u.rao>>06585000
   option privileged, uncallable, forward;                     <<u.rao>>06590000
                                                               <<u.rao>>06595000
   procedure delimpfile(parm,fname);                                    06600000
   value parm;                                                          06605000
   logical parm;                                                        06610000
   byte array fname;                                                    06615000
   option privileged, uncallable, forward;                              06620000
procedure ferror'(fnum,parmnum);                               <<u.rao>>06625000
value fnum;                                                    <<u.rao>>06630000
integer fnum,parmnum;                                          <<u.rao>>06635000
option privileged, uncallable,external;                        << i.a >>06640000
                                                                        06645000
   procedure cierr(errnum,erradr,parmmask,parm);               <<u.rao>>06650000
   value errnum,parmmask,parm;                                 <<u.rao>>06655000
   integer errnum,parmmask,parm;                               <<u.rao>>06660000
   byte array erradr;                                          <<u.rao>>06665000
   option privileged,uncallable,variable,external;             << i.a >>06670000
                                                               <<u.rao>>06675000
   integer procedure syslist (element, level, parms, sirs);             06680000
   value level, parms, sirs;                                            06685000
   array element;                                                       06690000
   integer level, parms;                                                06695000
   double sirs;                                                         06700000
   option external, privileged, uncallable;                    << i.a >>06705000
                                                                        06710000
procedure cydirerr'(direcreturn,okmask,errnum);                <<u.rao>>06715000
value direcreturn,okmask;                                      <<u.rao>>06720000
double direcreturn;                                            <<u.rao>>06725000
integer errnum;                                                <<u.rao>>06730000
logical okmask;                                                <<u.rao>>06735000
option privileged,uncallable,external;                         << i.a >>06740000
                                                                        06745000
   procedure get'filecode(filecode,mnemonic,mnemonic'length);  <<01454>>06750000
   integer filecode,mnemonic'length;                           <<01454>>06755000
   byte array mnemonic;                                        <<01454>>06760000
   option uncallable,privileged,forward;                       <<01454>>06765000
                                                               <<01454>>06770000
integer procedure checkfilename'(pdef,gptr,aptr,errptr);       <<u.rao>>06775000
value pdef; double pdef;                                       <<u.rao>>06780000
logical gptr,aptr,errptr;                                      <<u.rao>>06785000
option privileged, uncallable, external;                       << i.a >>06790000
                                                               <<u.rao>>06795000
<< chk'describe'fname is an entry point to checkfilename'. >>  <<04848>>06800000
integer procedure chk'describe'fname( p, g, a, e );            <<04848>>06805000
value p;  double p;                                            <<04848>>06810000
logical g, a, e;                                               <<04848>>06815000
option privileged, uncallable, external;                       <<04848>>06820000
                                                               <<04848>>06825000
logical procedure cibadfilename(errnum,parm);                  <<u.rao>>06830000
value parm;                                                    <<u.rao>>06835000
integer errnum;                                                <<u.rao>>06840000
double parm;                                                   <<u.rao>>06845000
option privileged,uncallable,external;                         << i.a >>06850000
                                                               <<u.rao>>06855000
integer procedure checkhomeacct(ppresult);                     <<u.rao>>06860000
integer array ppresult;                                        <<u.rao>>06865000
option privileged, uncallable, external;                       << i.a >>06870000
                                                                        06875000
procedure reset'terminalmode;                                  <<00851>>06880000
option uncallable,forward;                                     <<00851>>06885000
logical procedure createerror;                                 <<u.rao>>06890000
option privileged,uncallable,external;                         << i.a >>06895000
                                                               <<u.rao>>06900000
   integer procedure getflabel(fileref,len,flabel,fldn,                 06905000
   faddr,fnum,sirinfo);                                        <<04.ro>>06910000
   value len;                                                           06915000
   integer len,fldn;                                                    06920000
   integer fnum;                                               <<04.ro>>06925000
   array flabel;                                                        06930000
   byte array fileref;                                                  06935000
   double faddr,sirinfo;                                                06940000
   option forward,variable,privileged,uncallable;                       06945000
                                                                        06950000
   procedure resetdump;                                                 06955000
   option forward,privileged;                                           06960000
                                                                        06965000
   procedure setdump(flags);                                            06970000
   value flags;                                                         06975000
   logical flags;                                                       06980000
   option privileged,forward;                                           06985000
                                                                        06990000
   logical procedure requestservice;                                    06995000
   option privileged,uncallable,external;                      << i.a >>07000000
                                                                        07005000
   logical procedure createproc'err(error,errnum);             <<01452>>07010000
   value error; integer error,errnum;                          <<01452>>07015000
   option privileged,uncallable,external;                      << i.a >>07020000
                                                               <<01452>>07025000
logical procedure cisubsysfinish(messgtype,errnum,parmnum);    <<01452>>07030000
   value messgtype;                                            <<01452>>07035000
   integer messgtype,errnum,parmnum;                           <<01452>>07040000
   option uncallable,privileged,forward;                       <<01452>>07045000
                                                                        07050000
logical procedure jobsessionmain; option external;             << i.a >>07055000
                                                               <<14.eb>>07060000
logical procedure implicitmnt(group,acct,mountdst,pv'error);   << i.a >>07065000
  array group,acct;                                            << i.a >>07070000
  integer mountdst,pv'error;                                   << i.a >>07075000
  option privileged,uncallable,                                << i.a >>07080000
         external;                                             << i.a >>07085000
                                                               << i.a >>07090000
double procedure direcfindfile( type, linkage'indexp,          << 8921>>07095000
                                acct'name, grp'name, file'name,<< 8921>>07100000
                                preturn, mvtabx );             << 8921>>07105000
value type, linkage'indexp, mvtabx;                            << 8921>>07110000
logical type, mvtabx;                                          << 8921>>07115000
double linkage'indexp;                                         << 8921>>07120000
logical array acct'name, grp'name, file'name, preturn;         << 8921>>07125000
option privileged, uncallable, variable, external;             << 8921>>07130000
                                                               << 8921>>07135000
double procedure direcfind( type, linkage'indexp,              << 8921>>07140000
                                acct'name, grp'name, file'name,<< 8921>>07145000
                                preturn );                     << 8921>>07150000
value type, linkage'indexp;                                    << 8921>>07155000
logical type;                                                  << 8921>>07160000
double linkage'indexp;                                         << 8921>>07165000
logical array acct'name, grp'name, file'name, preturn;         << 8921>>07170000
option privileged, uncallable, external;                       << 8921>>07175000
                                                               << 8921>>07180000
procedure mount( vsname, vsgroup, vsacct, req'type,            << 8921>>07185000
                 gen,    pvinfo,  different'pin     );         << 8921>>07190000
value gen, different'pin;                                      << 8921>>07195000
integer req'type, gen, pvinfo, different'pin;                  << 8921>>07200000
byte array vsname, vsgroup, vsacct;                            << 8921>>07205000
option privileged, uncallable, variable, external;             << 8921>>07210000
                                                               << 8921>>07215000
$page    "FILE AND BUILD COMMAND EXECUTORS"                             07220000
$control   segment  =  cifileb                                          07225000
                                                                        07230000
logical procedure checkexpdate(errnum, fieldlen, datasource,   <<u.rao>>07235000
    datatarget);                                               <<u.rao>>07240000
value fieldlen;                                                <<u.rao>>07245000
integer errnum, fieldlen;                                      <<u.rao>>07250000
byte array datasource, datatarget;                             <<u.rao>>07255000
option internal;                                               <<04.ro>>07260000
<<this procedure checks the expiration date field for labeled>><<u.rao>>07265000
<<tapes.  the format for this field is mm/dd/yy.  they may all><<u.rao>>07270000
<<be zero.  the procedure calls cierr directly.  errnum is the><<u.rao>>07275000
<<usual ci error parameter.  fieldlen is the length of the >>  <<u.rao>>07280000
<<expiration date field as determined in the file command by>> <<u.rao>>07285000
<<mycommand.  it is used to check for extraneous data.  >>     <<u.rao>>07290000
<<datasource and datatarget are just what they seem.    >>     <<u.rao>>07295000
begin                                                          <<u.rao>>07300000
integer month;                                                 <<u.rao>>07305000
integer day;                                                   <<u.rao>>07310000
integer year;                                                  <<u.rao>>07315000
integer numlen;  <<length of the individual data field>>       <<u.rao>>07320000
integer maxdays;  <<used to cope with leap year complications>><<u.rao>>07325000
byte pointer sourceptr;   <<current location in source>>       <<u.rao>>07330000
integer array montharr(0:1) = pb :=    <<days of each month>>  <<u.rao>>07335000
   0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31;          <<u.rao>>07340000
subroutine gettoken(target);                                   <<u.rao>>07345000
integer target;                                                <<u.rao>>07350000
<<finds and computes each part of the date field>>             <<u.rao>>07355000
begin                                                          <<u.rao>>07360000
scan sourceptr while [8/%15,8/" "],1;                          <<u.rao>>07365000
@sourceptr := tos;                                             <<u.rao>>07370000
move sourceptr := sourceptr while n,1;                         <<u.rao>>07375000
numlen := tos-@sourceptr;                                      <<u.rao>>07380000
target := binary(sourceptr, numlen);  <<convert to binary>>    <<u.rao>>07385000
end;                                                           <<u.rao>>07390000
@sourceptr := @datasource;                                     <<u.rao>>07395000
move datatarget := "00/00/0";  <<initialize return space>>     <<u.rao>>07400000
gettoken(month);   <<compute month value>>                     <<u.rao>>07405000
if not(1<=numlen<=2) or not(0<=month<=12) then   <<invalid mont<<u.rao>>07410000
   cierr(errnum := filexpinvmonth, sourceptr)                  <<u.rao>>07415000
else                                                           <<u.rao>>07420000
   begin   <<month checked out ok, do day>>                    <<u.rao>>07425000
   ascii(month, -10, datatarget(1));  <<put in result field>>  <<u.rao>>07430000
   scan sourceptr(numlen) while [8/%15,8/" "],1;               <<u.rao>>07435000
   if bps0 <> "/" then                                         <<u.rao>>07440000
      cierr(errnum := filexpnoslashmd, bps0)                   <<u.rao>>07445000
   else   <<found slash, look for day>>                        <<u.rao>>07450000
      begin                                                    <<u.rao>>07455000
      @sourceptr := tos+1;                                     <<u.rao>>07460000
      gettoken(day);                                           <<u.rao>>07465000
      if month=0 and day<>0 then  <<00/00/00 bad>>             <<u.rao>>07470000
         cierr(errnum := filexpdayzero, sourceptr)             <<u.rao>>07475000
      else if not(1<=numlen<=2) then                           <<00617>>07480000
         cierr(errnum := filexpinvday,sourceptr,%10000,maxdays)<<u.rao>>07485000
      else   <<day checked out>>                               <<u.rao>>07490000
         begin                                                 <<u.rao>>07495000
         ascii(day, -10, datatarget(4));                       <<u.rao>>07500000
         scan sourceptr(numlen) while [8/%15,8/" "],1;         <<u.rao>>07505000
         if bps0 <> "/" then                                   <<u.rao>>07510000
            cierr(errnum := filexpnoslashdy, bps0)             <<u.rao>>07515000
         else                                                  <<u.rao>>07520000
            begin                                              <<u.rao>>07525000
            @sourceptr := tos+1;                               <<u.rao>>07530000
            gettoken(year);                                    <<u.rao>>07535000
            maxdays:=montharr(month) + <<leap year correction>><<00617>>07540000
               (if year mod 4 = 0 and month=2 then 1 else 0);  <<00617>>07545000
            if month <> 0 and not(1<=day<=maxdays) then        <<00617>>07550000
               cierr(errnum:=filexpinvday,,%10000,maxdays)     <<00617>>07555000
            else                                               <<00617>>07560000
            if month=0 and year<>0 then  <<expected 00/00/00>> <<u.rao>>07565000
               cierr(errnum := filexpnonzero, sourceptr)       <<u.rao>>07570000
            else                                               <<u.rao>>07575000
               if @sourceptr(numlen)-@datasource <> fieldlen then       07580000
                  cierr(errnum := filexpxtrndata, sourceptr(numlen))    07585000
            else   <<all checked out, do it>>                  <<u.rao>>07590000
               begin                                           <<u.rao>>07595000
               ascii(year, -10, datatarget(7));                <<u.rao>>07600000
               checkexpdate := true;                           <<u.rao>>07605000
               end;                                            <<u.rao>>07610000
            end;                                               <<u.rao>>07615000
         end;                                                  <<u.rao>>07620000
      end;                                                     <<u.rao>>07625000
   end;                                                        <<u.rao>>07630000
end;   <<procedure checkexpdate>>                              <<u.rao>>07635000
procedure cxfile executorhead;                                 <<u.rao>>07640000
option privileged, uncallable;                                 <<u.rao>>07645000
begin                                                          <<u.rao>>07650000
byte array pkeylist (0:1) = pb :=                              <<u.rao>>07655000
   << flags-byte (following word) = disallow new/old/sys($)/buil>>      07660000
   6,3, "DEV", 0,                                              <<u.rao>>07665000
   7,4, "DISC", 6,                                             <<u.rao>>07670000
   6,3, "REC", 0,                                              <<u.rao>>07675000
   7,4, "CODE", 2,                                             <<u.rao>>07680000
   7,4, "CCTL", 0,                                             <<u.rao>>07685000
   9,6, "NOCCTL", 0,                                           <<u.rao>>07690000
   7,4, "TEMP", 2,                                             <<u.rao>>07695000
   7,4, "SAVE", 3,                                             <<u.rao>>07700000
   6,3, "DEL", 3,                                              <<u.rao>>07705000
   6,3, "ACC", 1,                                              <<u.rao>>07710000
   6,3, "SHR", 1,                                              <<u.rao>>07715000
   6,3, "EAR", 1,                                              <<u.rao>>07720000
   7,4, "SEMI", 1,                                             <<01549>>07725000
   6,3, "EXC", 1,                                              <<u.rao>>07730000
   6,3, "BUF", 1,                                              <<u.rao>>07735000
   8,5, "NOBUF", 1,                                            <<u.rao>>07740000
   7,4, "COPY", 1,                                             <<01549>>07745000
   9,6, "NOCOPY", 1,                                           <<01549>>07750000
   5,2, "MR", 1,                                               <<u.rao>>07755000
   7,4, "NOMR", 1,                                             <<u.rao>>07760000
   9,6, "GMULTI", 1,                                           <<01549>>07765000
   8,5, "MULTI", 1,                                            <<u.rao>>07770000
   10,7, "NOMULTI", 1,                                         <<u.rao>>07775000
   10,7, "NOLABEL", 3,                                         <<u.rao>>07780000
   8,5, "FORMS", 1,                                            <<u.rao>>07785000
   8,5, "LABEL", 3,                                            <<u.rao>>07790000
   7,4, "LOCK", 1,                                             <<u.rao>>07795000
   9,6, "NOLOCK", 1,                                           <<u.rao>>07800000
   7,4, "WAIT", 1,                                             <<u.rao>>07805000
   9,6, "NOWAIT", 1,                                           <<u.rao>>07810000
   6,3, "STD", 3,                                              <<01724>>07815000
   6,3, "RIO",2,                                               <<00634>>07820000
   8,5, "NORIO",2,                                             <<00634>>07825000
   6,3,"ENV",1,                                                <<01549>>07830000
   7,4,"OUTQ", 1,                                              <<01549>>07835000
   6,3, "MSG", 2,                                              <<01549>>07840000
   6,3, "CIR", 2,                                              <<01549>>07845000
   6,3, "DEN", 3,                                              <<02569>>07850000
   0;                                                          <<u.rao>>07855000
equate pkeylistl = 272;                                        <<02569>>07860000
byte array keylist (0:pkeylistl-1);                            <<u.rao>>07865000
byte array pacctypes(0:1) = pb :=                              <<u.rao>>07870000
   4,2, "IN",                                                  <<u.rao>>07875000
   5,3, "OUT",                                                 <<u.rao>>07880000
   9,7, "OUTKEEP",                                             <<u.rao>>07885000
   8,6, "APPEND",                                              <<u.rao>>07890000
   7,5, "INOUT",                                               <<u.rao>>07895000
   8,6, "UPDATE",                                              <<u.rao>>07900000
   0;                                                          <<u.rao>>07905000
equate acctypel = 42;                                          <<u.rao>>07910000
byte array acctypes(0:acctypel-1);                             <<u.rao>>07915000
entry cxbuild, parse'file'eq;                                  <<01200>>07920000
label startparse;          << commom code to both entry pts >> <<01200>>07925000
                                                               <<u.rao>>07930000
<<variables for the parse>>                                    <<u.rao>>07935000
logical buildflag := false;                                    <<u.rao>>07940000
integer numparms;                                              <<u.rao>>07945000
equate maxparms = 32;                                          <<01549>>07950000
byte pointer parmptr;  <<pointer to current parameter>>        <<u.rao>>07955000
integer parmlen;  <<length of current parameter>>              <<u.rao>>07960000
byte savedelim;                                                <<02053>>07965000
integer nextdelim;  <<delimiter following current parameter>>  <<u.rao>>07970000
double delims := [8/",",8/"=",8/";",8/%15]d;                   <<01117>>07975000
byte array bdelims (*) = delims;                               <<01117>>07980000
define delimtype = (13:3)#;                                    <<u.rao>>07985000
equate comma = 0,  <<equates for index in delimiter array>>    <<u.rao>>07990000
       equals = 1,                                             <<u.rao>>07995000
       semicolon = 2,                                          <<u.rao>>08000000
       cr = 3;                                                 <<u.rao>>08005000
integer comtype;  <<holds type of command while in prockey>>   <<u.rao>>08010000
equate build = 0,  <<equates for values of comtype>>           <<u.rao>>08015000
       sysdef = 1,                                             <<u.rao>>08020000
       old = 2,                                                <<u.rao>>08025000
       new = 3;                                                <<u.rao>>08030000
logical gpntr := 0,   <<hold byte pointers to appropriate entry<<u.rao>>08035000
        apntr := 0,                                            <<u.rao>>08040000
        gpntr2 := 0,                                           <<u.rao>>08045000
        apntr2 := 0,                                           <<u.rao>>08050000
        apntrenv := 0,   <<"ENV=FILENAME">>                    <<01549>>08055000
        gpntrenv := 0,                                         <<01549>>08060000
        errpntr := 0;                                          <<u.rao>>08065000
byte pointer group = gpntr,                                    <<u.rao>>08070000
             acct = apntr,                                     <<u.rao>>08075000
             group2 = gpntr2,                                  <<u.rao>>08080000
             acct2 = apntr2,                                   <<u.rao>>08085000
             groupenv = gpntrenv,                              <<02554>>08090000
             acctenv  = apntrenv,                              <<02554>>08095000
             erradr = errpntr;                                 <<u.rao>>08100000
                                                               <<u.rao>>08105000
<<variables for the execution phase>>                          <<u.rao>>08110000
byte pointer dictptr;  <<dictionary pointer for search intrinsic>>      08115000
array wentry(0:71);   <<holds prototype entry for jdt>>        <<u.rao>>08120000
byte array bentry(*)=wentry;                                   <<u.rao>>08125000
integer array                                                  <<02554>>08130000
   file'entry(0:71),      << holds file entry from jdt >>      <<02554>>08135000
   dest(0:14);            << holds output of crunch    >>      <<02554>>08140000
integer                                                        <<02554>>08145000
   size,                  << for crunch call           >>      <<02554>>08150000
   index;                 << general loop variable     >>      <<02554>>08155000
byte array                                                     <<02554>>08160000
   bfile'entry(*) = file'entry;                                <<02554>>08165000
integer nextentryx := 6;  <<used in setting up wentry>>        <<u.rao>>08170000
byte blank := " ";                                             <<u.rao>>08175000
                                                               <<u.rao>>08180000
<<data variables>>                                             <<u.rao>>08185000
byte array formsmsg(0:73);                                     <<u.rao>>08190000
byte array tapelabel(*)=formsmsg(49);                          <<u.rao>>08195000
byte array savedcomimage(0:cis'bcombuflen - 1);                << i.a >>08200000
integer formsmsglen := 0;                                      <<u.rao>>08205000
integer tapelabellen := 0;                                     <<u.rao>>08210000
equate                                                         <<04171>>08215000
   maxdevlen      = 63,   << contains extra space for       >> <<06552>>08220000
                          << chaning ds nodes together.     >> <<06552>>08225000
                          << note that fopen's buffer is    >> <<06552>>08230000
                          << slightly smaller.              >> <<06552>>08235000
   maxdevclasslen = 8;  << maximum device class name >>        <<04171>>08240000
integer devlen := 0;                                           <<u.rao>>08245000
double disc := "DISC";                                         <<u.rao>>08250000
byte pointer dev := @disc;                                     <<u.rao>>08255000
integer array devinfo(0:12);                                   <<06841>>08260000
byte pointer bptr;                                             <<01117>>08265000
define                                                         <<04171>>08270000
   flush'command =                                             <<04171>>08275000
      begin                                                    <<04171>>08280000
         parse'err(errnum,bptr);                               <<04171>>08285000
         return;                                               <<04171>>08290000
      end;#;                                                   <<04171>>08295000
logical foptions := 0;                                         <<u.rao>>08300000
logical aoptions := 0;                                         <<u.rao>>08305000
logical flags1 := 0;  <<prototype parameter present mask>>     <<u.rao>>08310000
logical flags2 := 0;  <<word 2 of flags>>                      <<u.rao>>08315000
equate delete = 4,   <<equates for disposition parameters>>    <<u.rao>>08320000
       temp = 2,                                               <<u.rao>>08325000
       save = 1;                                               <<u.rao>>08330000
equate std = 0,  <<equates for file type>>                     <<01549>>08335000
       rio = 2,                                                <<01549>>08340000
       cir = 4,                                                <<01549>>08345000
       msg = 6;                                                <<01549>>08350000
equate nomulti     = 0,  <<equates for multiaccess>>           <<01549>>08355000
       localmulti  = 1,                                        <<01549>>08360000
       globalmulti = 2;                                        <<01549>>08365000
integer disposition := save;  <<disposition of file at close>> <<u.rao>>08370000
integer recsize := 0;                                          <<u.rao>>08375000
integer blockfactor := 0;                                      <<u.rao>>08380000
double filesize := 0d;                                         <<u.rao>>08385000
integer numextents := 0;                                       <<u.rao>>08390000
integer initalloc := 0;                                        <<u.rao>>08395000
integer outpri := 0;                                           <<u.rao>>08400000
integer numcopies := 0;                                        <<u.rao>>08405000
integer filecode := 0;                                         <<u.rao>>08410000
integer numbuffers := 0;                                       <<u.rao>>08415000
equate exclusive     = 1,                                      << i.a >>08420000
       exclusiveread = 2,                                      <<u.rao>>08425000
       share         = 3;                                      <<u.rao>>08430000
logical parse'only;          << true if only doing parse >>    <<01200>>08435000
logical stop;                                                  <<02663>>08440000
<< variables for fopen device parameter keywords >>            <<02569>>08445000
byte pointer                                                   <<01851>>08450000
   dens,                                                       <<02569>>08455000
   outq,                                                       <<01851>>08460000
   env;                                                        <<01851>>08465000
integer                                                        <<01851>>08470000
   dummy,          << dummy for procedure call >>              <<02569>>08475000
   denslen := 0,                                               <<02569>>08480000
   envlen := 0,                                                <<01851>>08485000
   outqlen := 0,                                               <<01851>>08490000
   keys'len := 0;  << total length of device parms >>          <<02569>>08495000
logical flags3 := false;                                       <<01549>>08500000
define                                                         <<01549>>08505000
   flagdens = flags3.(12:1)#,                                  <<02569>>08510000
   flagadev = flags3.(15:1)#,                                  <<01549>>08515000
   flagenv = flags3.(14:1)#,                                   <<01549>>08520000
   flagoutq = flags3.(13:1)#;                                  <<01549>>08525000
integer                                                        <<04843>>08530000
   errloc;     << local error number copy. >>                  <<04843>>08535000
                                                               <<04843>>08540000
                                                               <<u.rao>>08545000
                                                               <<02569>>08550000
<< the parms array (and its equivalences) must be the last >>  <<02569>>08555000
<< q-relative variable defined in the procedure because it >>  <<02569>>08560000
<< is a direct array.  otherwise, the procedure will run   >>  <<02569>>08565000
<< out of primary q space. >>                                  <<02569>>08570000
                                                               <<02569>>08575000
double array parms(0:maxparms) = q;                            <<02569>>08580000
byte pointer formaldes = parms;                                <<02569>>08585000
byte pointer actualdes = parms + 2;                            <<02569>>08590000
byte actualdeslen = parms + 3;                                 <<02569>>08595000
                                                               <<02569>>08600000
<<foptions defines>>                                           <<u.rao>>08605000
define                                                         <<u.rao>>08610000
   filetype    = (2:3) #,                                      <<01549>>08615000
   tapelabelf  = (6:1)#,                                       <<u.rao>>08620000
   cctl        = (7:1)#,                                       <<u.rao>>08625000
   recordfmt   = (8:2)#,                                       <<u.rao>>08630000
   defaultdes  = (10:3)#,                                      <<u.rao>>08635000
   asciibinary = (13:1)#,                                      <<u.rao>>08640000
   domain      = (14:2)#;                                      <<u.rao>>08645000
                                                               <<u.rao>>08650000
<<aoptions defines>>                                           <<u.rao>>08655000
define                                                         <<u.rao>>08660000
   copy        = (3:1)#,                                       <<01549>>08665000
   nowait      = (4:1)#,                                       <<u.rao>>08670000
   multiaccess = (5:2)#,                                       <<01549>>08675000
   nobuf       = (7:1)#,                                       <<u.rao>>08680000
   exclaccess  = (8:2)#,                                       <<u.rao>>08685000
   locking     = (10:1)#,                                      <<u.rao>>08690000
   multirecord = (11:1)#,                                      <<u.rao>>08695000
   accesstype  = (12:4)#;                                      <<u.rao>>08700000
                                                               <<u.rao>>08705000
<<parameter bit mask defines - see jdt description>>           <<u.rao>>08710000
define                                                         <<u.rao>>08715000
   flaganame       = flags1.(15:1)#,                           <<u.rao>>08720000
   flagdev         = flags1.(14:1)#,                           <<u.rao>>08725000
   flagdomain      = flags1.(13:1)#,                           <<u.rao>>08730000
   flagascii       = flags1.(12:1)#,                           <<u.rao>>08735000
   flagdefdesig    = flags1.(11:1)#,                           <<u.rao>>08740000
   flagrecfmt      = flags1.(10:1)#,                           <<u.rao>>08745000
   flagcctl        = flags1.(9:1)#,                            <<u.rao>>08750000
   flagcopy        = flags1.(8:1) #,                           <<01549>>08755000
   flagaccesstype  = flags1.(7:1)#,                            <<u.rao>>08760000
   flagmultirec    = flags1.(6:1)#,                            <<u.rao>>08765000
   flagexclusive   = flags1.(5:1)#,                            <<u.rao>>08770000
   flagbufinhibit  = flags1.(4:1)#,                            <<u.rao>>08775000
   flagnumbufs     = flags1.(3:1)#,                            <<u.rao>>08780000
   flagdisp        = flags1.(2:1)#,                            <<u.rao>>08785000
   flagrecsize     = flags1.(1:1)#,                            <<u.rao>>08790000
   flagblockfactor = flags1.(0:1)#,                            <<u.rao>>08795000
   flaginitalloc   = flags2.(15:1)#,                           <<u.rao>>08800000
   flagnumexts     = flags2.(14:1)#,                           <<u.rao>>08805000
   flagfilesize    = flags2.(13:1)#,                           <<u.rao>>08810000
   flagfilecode    = flags2.(12:1)#,                           <<u.rao>>08815000
   flagoutpri      = flags2.(11:1)#,                           <<u.rao>>08820000
   flagnumcopies   = flags2.(10:1)#,                           <<u.rao>>08825000
   flagmultiaccess = flags2.(9:1)#,                            <<u.rao>>08830000
   flagwait        = flags2.(8:1)#,                            <<u.rao>>08835000
   flagdynlocking = flags2.(7:1)#,                             <<u.rao>>08840000
   flagvterm       = flags2.(5:1)#,  << virtual terminal >>             08845000
   flaglang        = flags2.(4:1)#,  << native language  >>             08850000
   flaguserlabels  = flags2.(3:1)#,                                     08855000
   flagforms      = flags2.(2:1)#,                             <<u.rao>>08860000
   flaglabeledtape= flags2.(1:1)#,                             <<u.rao>>08865000
   flagftype      = flags2.(0:1)#;                             <<01549>>08870000
<< jdt file entry defines - see jdt description >>             <<02554>>08875000
define                                                         <<02554>>08880000
   formal'des'len        = file'entry.(8:8)#,                  <<02554>>08885000
   formal'des'name       = bfile'entry(2)#,                    <<02554>>08890000
   actual'des'len        = file'entry(formal'des'len +         <<02554>>08895000
                                       3).(0:8)#,              <<02554>>08900000
   device'des'len        = file'entry(formal'des'len +         <<02554>>08905000
                                       3).(8:8)#,              <<02554>>08910000
   device'des'name       = bfile'entry(formal'des'len * 2 +    <<02554>>08915000
                                      actual'des'len +         <<02554>>08920000
                                       8)#,                    <<02554>>08925000
   device'present        = file'entry(formal'des'len +         <<02554>>08930000
                                       1).(14:1)#;             <<02554>>08935000
                                                               <<u.rao>>08940000
                                                               <<04848>>08945000
define      << lockword found by chk'describe'fname. >>        <<04848>>08950000
   gotlock     = ( errloc.(0:1) = 1 ) #;                       <<04843>>08955000
                                                               <<04843>>08960000
                                                               <<01200>>08965000
<<                 *********************                   >>  <<01200>>08970000
<<                 *     parse'err     *                   >>  <<01200>>08975000
<<                 *********************                   >>  <<01200>>08980000
                                                               <<01200>>08985000
subroutine parse'err (error, erradr);                          <<01200>>08990000
 value error;                                                  <<01200>>08995000
  integer error;                                               <<01200>>09000000
  byte array erradr;                                           <<01200>>09005000
<< subroutine to handle errors encountered during file      >> <<01200>>09010000
<< equation parsing.  if a special parse is in progress     >> <<01200>>09015000
<< (i.e. parse'only = true) then simply set the error       >> <<01200>>09020000
<< return.  if a ci command is being executed (i.e. :file   >> <<01200>>09025000
<< :build) then call cierr.                                 >> <<01200>>09030000
begin                                                          <<01200>>09035000
errnum := error;                                               <<04843>>09040000
if not parse'only then                                         <<01200>>09045000
  cierr (error, erradr);                                       <<01200>>09050000
end << parse'err >>;                                           <<01200>>09055000
                                                               <<u.rao>>09060000
<<                 *********************                   >>  <<u.rao>>09065000
<<                 *      getnext      *                   >>  <<u.rao>>09070000
<<                 *********************                   >>  <<u.rao>>09075000
                                                               <<u.rao>>09080000
subroutine getnext;                                            <<u.rao>>09085000
<<this subroutine extracts the next parameter from parms>>     <<u.rao>>09090000
<<and decomposes the mycommand returned entry.  it also checks><<u.rao>>09095000
<<for the too many parameters case.  >>                        <<u.rao>>09100000
begin                                                          <<u.rao>>09105000
tos := parms(parmnum);  <<get next entry>>                     <<u.rao>>09110000
nextdelim := s0.delimtype;  <<get trailing delimiter>>         <<u.rao>>09115000
parmlen := tos&lsr(8);  <<length of entry>>                    <<u.rao>>09120000
@parmptr := tos;  <<first word of mycommand entry>>            <<u.rao>>09125000
parmnum := parmnum+1;                                          <<u.rao>>09130000
if parmnum > maxparms then  <<too many parameters>>            <<u.rao>>09135000
   begin                                                       <<u.rao>>09140000
   if buildflag then                                           <<u.rao>>09145000
      parse'err(errnum := bld2mp,parmptr)                      <<01200>>09150000
   else                                                        <<u.rao>>09155000
      parse'err(errnum := file2mp,parmptr);                    <<01200>>09160000
   assemble(exit 3);  <<bail out of cxfile>>                   <<u.rao>>09165000
   end;                                                        <<u.rao>>09170000
end;  <<subroutine getnext>>                                   <<u.rao>>09175000
                                                               <<u.rao>>09180000
<<                 *********************                   >>  <<u.rao>>09185000
<<                 *    checkfdesig    *                   >>  <<u.rao>>09190000
<<                 *********************                   >>  <<u.rao>>09195000
                                                               <<u.rao>>09200000
logical subroutine checkfdesig;                                <<u.rao>>09205000
begin                                                          <<u.rao>>09210000
<<note:  a formal file designator must have the same format>>  <<u.rao>>09215000
<<as an actual file designator, but it may not be a system>>   <<u.rao>>09220000
<<defined file or a back referenced file.>>                    <<u.rao>>09225000
checkfdesig := false;                                          <<u.rao>>09230000
getnext;  <<explode parms entry for file name>>                <<u.rao>>09235000
errloc := chk'describe'fname(parms&lsr(8),gpntr,apntr,errpntr);<<04843>>09240000
if < then  <<error in name>>                                   <<u.rao>>09245000
   parse'err( errloc, erradr )                                 <<04843>>09250000
else if > then  <<not standard file name>>                     <<u.rao>>09255000
   if errloc.(8:8) = 0 then  << back-ref'd file. >>            <<04843>>09260000
      parse'err(errnum := filefdsgnoback, formaldes)           <<01200>>09265000
   else                                                        <<u.rao>>09270000
      parse'err(errnum := filefdsgnosys, formaldes)            <<01200>>09275000
else  <<ok - regular formal designator>>                       <<u.rao>>09280000
   begin                                                       <<u.rao>>09285000
   if gotlock then                                             <<04848>>09290000
   begin                                                       <<04848>>09295000
      parse'err( errnum := fdesgnolock, formaldes );           <<04848>>09300000
      return;                                                  <<04848>>09305000
   end;                                                        <<04848>>09310000
   checkfdesig := true;                                        <<u.rao>>09315000
   if gpntr = 0 then gpntr := @blank;                          <<u.rao>>09320000
   if apntr = 0 then apntr := @blank;                          <<u.rao>>09325000
   end                                                         <<u.rao>>09330000
end;                                                           <<u.rao>>09335000
                                                               <<u.rao>>09340000
<<                 *********************                   >>  <<u.rao>>09345000
<<                 *  bldcheckfdesig   *                   >>  <<u.rao>>09350000
<<                 *********************                   >>  <<u.rao>>09355000
                                                               <<u.rao>>09360000
logical subroutine bldcheckfdesig;                             <<u.rao>>09365000
begin                                                          <<u.rao>>09370000
<<note:  a formal file designator must have the same format>>  <<u.rao>>09375000
<<as an actual file designator, but it may not be a system>>   <<u.rao>>09380000
<<defined file>>                                               <<u.rao>>09385000
bldcheckfdesig := false;                                       <<u.rao>>09390000
getnext;  <<explode parms entry for file name>>                <<u.rao>>09395000
errnum := checkfilename'(parms&lsr(8),gpntr,apntr,errpntr);    <<u.rao>>09400000
if < then  <<error in name>>                                   <<u.rao>>09405000
   parse'err(errnum,erradr)                                    <<01200>>09410000
else if > and errnum<>0 and errnum<>2 then  <<not std file name<<u.rao>>09415000
   parse'err(errnum := bldnosysfiles, formaldes)               <<01200>>09420000
else if errnum=2 then   <<is $newpass, allow>>                 <<u.rao>>09425000
   begin                                                       <<00449>>09430000
   bldcheckfdesig := true;                                     <<00449>>09435000
   errnum := 0;                                                <<00449>>09440000
   end                                                         <<00449>>09445000
else  <<ok - regular formal designator>>                       <<u.rao>>09450000
   begin                                                       <<u.rao>>09455000
   bldcheckfdesig := true;                                     <<u.rao>>09460000
   if gpntr = 0 then gpntr := @blank;                          <<u.rao>>09465000
   if apntr = 0 then apntr := @blank;                          <<u.rao>>09470000
   end                                                         <<u.rao>>09475000
end;                                                           <<u.rao>>09480000
                                                               <<u.rao>>09485000
<<                 *********************                   >>  <<u.rao>>09490000
<<                 *   checkadesig     *                   >>  <<u.rao>>09495000
<<                 *********************                   >>  <<u.rao>>09500000
                                                               <<u.rao>>09505000
logical subroutine checkadesig;                                <<u.rao>>09510000
<<check form of actual designator.  may be any sort of file nam<<u.rao>>09515000
<<if it is a back referenced file, we go ahead and do the file <<u.rao>>09520000
<<equate now, since it should not have any parameters.>>       <<u.rao>>09525000
begin                                                          <<u.rao>>09530000
getnext;                                                       <<u.rao>>09535000
checkadesig := true;                                           <<u.rao>>09540000
errloc := chk'describe'fname( parms(1)&lsr(8), gpntr2,         <<04843>>09545000
                              apntr2, errpntr           );     <<04848>>09550000
if < then  <<error in name>>                                   <<u.rao>>09555000
   begin                                                       <<u.rao>>09560000
   parse'err( errloc, erradr );                                <<04843>>09565000
   checkadesig := false                                        <<u.rao>>09570000
   end                                                         <<u.rao>>09575000
else if = then  <<ordinary actual file designator>>            <<u.rao>>09580000
   begin                                                       <<u.rao>>09585000
   flaganame := true                                           <<u.rao>>09590000
   end                                                         <<u.rao>>09595000
else if > and (errloc.(8:8) <> 0) then                         <<04843>>09600000
   begin  <<system defined file name>>                         <<u.rao>>09605000
   foptions.defaultdes := errloc.(8:8);                        <<04843>>09610000
   if (foptions.defaultdes=6) and (numparms>parmnum) then  <<parms>>    09615000
      begin  <<with $null, which is illegal>>                  <<u.rao>>09620000
      checkadesig := false;                                    <<u.rao>>09625000
      getnext;                                                 <<u.rao>>09630000
      parse'err(errnum := fileadesnull2mp, parmptr);           <<01200>>09635000
      end;                                                     <<u.rao>>09640000
   flagdefdesig := true;                                       <<u.rao>>09645000
   end                                                         <<u.rao>>09650000
else   <<must be back referenced file>>                        <<u.rao>>09655000
   begin                                                       <<u.rao>>09660000
   <<this is the end of the line for a back reference.  either><<u.rao>>09665000
   <<we will detect an error and report it or we will insert the>>      09670000
   <<entry into the job directory table (jdt).>>               <<u.rao>>09675000
   if gotlock then                                             <<04848>>09680000
   begin                                                       <<04848>>09685000
      parse'err( errnum := fdesgnolock, actualdes );           <<04848>>09690000
      checkadesig := false;                                    <<04848>>09695000
      return;                                                  <<04848>>09700000
   end;                                                        <<04848>>09705000
   checkadesig := false;                                       <<u.rao>>09710000
   if numparms > 2 then  <<too many parameters>>               <<u.rao>>09715000
      begin                                                    <<u.rao>>09720000
      getnext;  <<to force parmptr to the offending item>>     <<u.rao>>09725000
      parse'err(errnum := fileadesigbr2mp, parmptr)            <<01200>>09730000
      end                                                      <<u.rao>>09735000
   else                                                        <<u.rao>>09740000
      begin                                                    <<u.rao>>09745000
      <<create entry, attempt to insert it>>                   <<u.rao>>09750000
      if gpntr2 = 0 then gpntr2 := @blank;                     <<u.rao>>09755000
      if apntr2 = 0 then apntr2 := @blank;                     <<u.rao>>09760000
      @actualdes := @actualdes+1;  <<move past "*">>           <<u.rao>>09765000
      actualdeslen := actualdeslen-1;                          <<u.rao>>09770000
      parmnum := 0;  <<clean up return parameter>>             <<u.rao>>09775000
      <<now format wentry>>                                    <<u.rao>>09780000
      wentry := 1;   <<set pmask - name only parm present>>    <<u.rao>>09785000
      wentry(1) := %1000;  <<set pmask word 2 - pointer wentry><<u.rao>>09790000
      bentry(4) := actualdeslen;                               <<u.rao>>09795000
      bentry(5):=0;  <<clear devlen>>                          <<00080>>09800000
      move bentry(6) := actualdes,(actualdeslen);              <<u.rao>>09805000
      nextentryx := (actualdeslen+29)&lsr(1); <<length in words<<u.rao>>09810000
      if parse'only then                                       <<01200>>09815000
         begin                                                 <<01200>>09820000
         << copy local table entry over string passed to   >>  <<01200>>09825000
         << parse'file'eq.  this returns the parsed file   >>  <<01200>>09830000
         << equation info to the caller.                   >>  <<01200>>09835000
         move parmsp := bentry, (actualdeslen+8);              <<01200>>09840000
         end                                                   <<01200>>09845000
      else                                                     <<01200>>09850000
      case xaddjtentry(formaldes,group,acct,-3,nextentryx,wentry,       09855000
               actualdes,group2,acct2) of                      <<u.rao>>09860000
         begin                                                 <<u.rao>>09865000
            ;  <<0 - no problem>>                              <<u.rao>>09870000
            cierr(errnum := feqtabfullxplct);                  <<u.rao>>09875000
            ;  <<duplicate name can't happen>>                 <<u.rao>>09880000
            begin  <<actual designator not found>>             <<u.rao>>09885000
               qualifyfilename(actualdes,bentry);              <<u.rao>>09890000
               cierr(errnum := filebrefmisades,,0,@bentry);    <<u.rao>>09895000
            end;                                               <<u.rao>>09900000
            begin  <<too many back references>>                <<u.rao>>09905000
               qualifyfilename(actualdes,bentry);              <<u.rao>>09910000
               cierr(errnum := toomanyfeqbref,,0,@bentry);     <<u.rao>>09915000
            end;                                               <<u.rao>>09920000
            begin  << circular cline equations >>              <<00834>>09925000
               cierr(errnum := circularfeq);                   <<00834>>09930000
            end;                                               <<00834>>09935000
         end; <<of case>>                                      <<u.rao>>09940000
      end;                                                     <<u.rao>>09945000
   end;  << back reference case>>                              <<u.rao>>09950000
end;  <<checkadesig>>                                          <<u.rao>>09955000
                                                               <<u.rao>>09960000
                                                               <<01549>>09965000
<<                 *********************                   >>  <<01549>>09970000
<<                 * checkenvfiledesig *                   >>  <<02523>>09975000
<<                 *********************                   >>  <<01549>>09980000
                                                               <<01549>>09985000
logical subroutine checkenvfiledesig;                          <<02523>>09990000
<< check form of the actual file designator parameter      >>  <<02523>>09995000
<< for the "ENV=" keyword.  no system files allowed,       >>  <<02523>>10000000
<< except $oldpass.                                        >>  <<02523>>10005000
<<                                                         >>  <<02523>>10010000
begin                                                          <<01549>>10015000
checkenvfiledesig := false;                                    <<02554>>10020000
tos := checkfilename'(parms(parmnum-1)&lsr(8),gpntrenv,        <<01549>>10025000
           apntrenv,errpntr);                                  <<01549>>10030000
if < then  <<error in name>>                                   <<01549>>10035000
   begin                                                       <<01549>>10040000
   errnum := tos;                                              <<01549>>10045000
   parse'err(errnum, erradr);                                  <<01549>>10050000
   return;                                                     <<02554>>10055000
   end                                                         <<01549>>10060000
else if = then  <<ordinary actual file designator>>            <<01549>>10065000
   begin                                                       <<01549>>10070000
   del;                                                        <<01549>>10075000
   end                                                         <<01549>>10080000
else if > and (s0<>0) then                                     <<01549>>10085000
   begin  <<check for $oldpass>>                               <<01549>>10090000
   if s0 <> 3 <<not $oldpass>> then                            <<01549>>10095000
   begin  <<system defined file name>>                         <<01549>>10100000
      del;                                                     <<01851>>10105000
      parse'err(errnum := fileadessys, parmptr);               <<01549>>10110000
      return;                                                  <<02554>>10115000
   end                                                         <<01851>>10120000
   else del;                                                   <<01851>>10125000
   end                                                         <<01549>>10130000
else   <<must be back referenced file>>                        <<01549>>10135000
   begin                                                       <<01549>>10140000
   del;  <<pop zero from checkfilename'>>                      <<01549>>10145000
      <<it is a valid filename>>                               <<01549>>10150000
   if gpntrenv = 0 then gpntrenv := @blank;                    <<02554>>10155000
   if apntrenv = 0 then apntrenv := @blank;                    <<02554>>10160000
   if parmptr(1) = formaldes,(parmlen - 1) then                <<02554>>10165000
      parse'err(errnum := circularfeq,parmptr);                <<02554>>10170000
                                                               <<02554>>10175000
   if errnum > 0 then return;                                  <<06021>>10180000
   case xretjtentry(parmptr(1),groupenv,acctenv                <<02554>>10185000
                    ,size,file'entry) of                       <<02554>>10190000
      begin                                                    <<02554>>10195000
         begin                                                 <<02554>>10200000
            if logical(device'present) then                    <<02554>>10205000
               begin                                           <<02554>>10210000
                  index := -1;                                 <<02554>>10215000
                  @bptr := @device'des'name;                   <<02554>>10220000
                  while (index := index + 1) <=                <<02554>>10225000
                        (device'des'len - 5) do                <<02554>>10230000
                     if bptr(index) = ";ENV=" then             <<02554>>10235000
                     parse'err(errnum:=filecontenv,parmptr);   <<02554>>10240000
               end;                                            <<02554>>10245000
            if errnum > 0 then return;                         <<06021>>10250000
            crunch(formaldes,group,acct,dest,size);            <<02554>>10255000
            @bptr := @dest&lsl(1);                             <<02554>>10260000
            if bptr = formal'des'name,                         <<02554>>10265000
                      (formal'des'len * 2) then                <<02554>>10270000
               parse'err(errnum := circularfeq,parmptr);       <<02554>>10275000
         end;                                                  <<02554>>10280000
         begin                                                 <<02554>>10285000
            qualifyfilename(parmptr(1),bfile'entry);           <<02554>>10290000
            if parse'only then                                 <<02554>>10295000
               errnum := filebrefmisades                       <<02554>>10300000
            else                                               <<02554>>10305000
               cierr(errnum := filebrefmisades,,0,             <<02554>>10310000
                     @bfile'entry);                            <<02554>>10315000
         end;                                                  <<02554>>10320000
         begin                                                 <<02554>>10325000
            qualifyfilename(parmptr(1),bfile'entry);           <<02554>>10330000
            if parse'only then                                 <<02554>>10335000
               errnum := filebrefmisades                       <<02554>>10340000
            else                                               <<02554>>10345000
               cierr(errnum := filebrefmisades,,0,             <<02554>>10350000
                     @bfile'entry);                            <<02554>>10355000
         end;                                                  <<02554>>10360000
      end;         << case >>                                  <<02554>>10365000
   end;  << back reference case>>                              <<01549>>10370000
   if errnum <= 0 then checkenvfiledesig := true;              <<06021>>10375000
end;     <<checkenvfiledesig>>                                 <<02523>>10380000
                                                               <<01549>>10385000
<<                 *********************                   >>  <<u.rao>>10390000
<<                 *    checkdomain    *                   >>  <<u.rao>>10395000
<<                 *********************                   >>  <<u.rao>>10400000
                                                               <<u.rao>>10405000
logical subroutine checkdomain;                                <<u.rao>>10410000
begin                                                          <<u.rao>>10415000
<<this routine parses the domain parameter in a file equate.>> <<u.rao>>10420000
<<it also verifies that the domain and the default designator>><<u.rao>>10425000
<<are compatible.>>                                            <<u.rao>>10430000
checkdomain := true;                                           <<u.rao>>10435000
getnext;                                                       <<u.rao>>10440000
if foptions.defaultdes <> 0 then  <<domain specified for >>    <<u.rao>>10445000
   parse'err(-filedomainsysdf,parmptr)   << sys def file >>    <<01200>>10450000
else  <<is regular file reference>>                            <<u.rao>>10455000
   begin                                                       <<u.rao>>10460000
   flagdomain := true;   <<domain specified>>                  <<u.rao>>10465000
   if (parmlen=3) and (parmptr="OLD") then                     <<u.rao>>10470000
      foptions.domain := 1                                     <<u.rao>>10475000
   else if (parmlen=7) and (parmptr="OLDTEMP") then            <<u.rao>>10480000
      foptions.domain := 2                                     <<u.rao>>10485000
   else if (parmlen<>3) or (parmptr<>"NEW") then               <<u.rao>>10490000
      begin  <<unidentified domain>>                           <<u.rao>>10495000
      checkdomain := false;                                    <<u.rao>>10500000
      if parmlen = 0 then   <<missing>>                        <<u.rao>>10505000
         parse'err(errnum := filexpctdomain, parmptr)          <<01200>>10510000
      else                                                     <<u.rao>>10515000
         parse'err(errnum := fileinvlddomain, parmptr);        <<01200>>10520000
      end                                                      <<u.rao>>10525000
   end;                                                        <<u.rao>>10530000
end;  <<subroutine checkdomain>>                               <<u.rao>>10535000
                                                               <<u.rao>>10540000
<<                 *********************                   >>  <<u.rao>>10545000
<<                 *  checklabeldata   *                   >>  <<u.rao>>10550000
<<                 *********************                   >>  <<u.rao>>10555000
                                                               <<u.rao>>10560000
logical subroutine checklabeldata;                             <<u.rao>>10565000
<<checks syntax of tape label data.  form required is>>        <<u.rao>>10570000
<<label[=[volid][,[type][,[expiration date][,[sequence no.]]]]]<<u.rao>>10575000
begin                                                          <<u.rao>>10580000
checklabeldata := true;                                        <<u.rao>>10585000
foptions.tapelabelf := true;  <<flag requires tape label>>     <<u.rao>>10590000
flaglabeledtape := true;  <<internal flag for pmask>>          <<u.rao>>10595000
if <> then   <<redundantly specified parameter>>               <<u.rao>>10600000
   begin                                                       <<u.rao>>10605000
   parse'err(-fileredundlabel, parmptr);                       <<01200>>10610000
   tapelabellen := 0;                                          <<u.rao>>10615000
   end;                                                        <<u.rao>>10620000
if nextdelim=equals then   <<non-default specified>>           <<u.rao>>10625000
   begin                                                       <<u.rao>>10630000
   checklabeldata := false;                                    <<u.rao>>10635000
   getnext;                                                    <<u.rao>>10640000
   index := logical(@parmptr) - logical(@parmsp);              <<02663>>10645000
   @bptr := @savedcomimage(index);                             <<02663>>10650000
   if parmlen <> 0 then  <<volid present>>                     <<u.rao>>10655000
      if parmptr = """" then << special chars in volid >>      <<02663>>10660000
         begin                                                 <<02663>>10665000
         stop := false;                                        <<02663>>10670000
         @bptr := logical(@bptr) + 1;                          <<02663>>10675000
         while not stop do                                     <<02663>>10680000
            begin                                              <<02663>>10685000
            scan bptr until %6442,1; << quote'cr >>            <<02663>>10690000
            if carry then                                      <<02663>>10695000
               begin                                           <<02663>>10700000
               del;                                            <<02663>>10705000
               parse'err(errnum := filemissquote,parmptr);     <<02663>>10710000
               stop := true;                                   <<02663>>10715000
               end                                             <<02663>>10720000
            else                                               <<02663>>10725000
               begin                                           <<02663>>10730000
               index := ls0 - logical(@bptr);                  <<02663>>10735000
               @bptr := logical(tos);                          <<02663>>10740000
               if bptr(1) = """" then                          <<02663>>10745000
                  begin                                        <<02663>>10750000
                  index := index + 1;                          <<02663>>10755000
                  @bptr := logical(@bptr) + 1;                 <<02663>>10760000
                  end                                          <<02663>>10765000
               else                                            <<02663>>10770000
                  stop := true;                                <<02663>>10775000
               if (index + tapelabellen) > 6 then              <<02663>>10780000
                  begin                                        <<02663>>10785000
                  parse'err(errnum:=filevolid2long,parmptr);   <<02663>>10790000
                  stop := true;                                <<02663>>10795000
                  end                                          <<02663>>10800000
               else                                            <<02663>>10805000
                  begin                                        <<02663>>10810000
                  move tapelabel(tapelabellen) :=              <<02663>>10815000
                       bptr(-index),(index);                   <<02663>>10820000
                  tapelabellen := tapelabellen + index;        <<02663>>10825000
                  @bptr := logical(@bptr) + 1;                 <<02663>>10830000
                  end;                                         <<02663>>10835000
               end;                                            <<02663>>10840000
            end; << while loop >>                              <<02663>>10845000
         index := -1;                                          <<02663>>10850000
         while (index := index + 1) < tapelabellen and         <<02663>>10855000
               errnum = 0 do                                   <<02663>>10860000
            begin                                              <<02663>>10865000
            if not (%40 <= integer(tapelabel(index))           <<02663>>10870000
                        <= %176) then                          <<02663>>10875000
               parse'err(errnum := filenonprintchar,parmptr);  <<02663>>10880000
            if tapelabel(index) = "=" then getnext;            <<02663>>10885000
            if tapelabel(index) = ";" or                       <<02663>>10890000
               tapelabel(index) = "," then                     <<02663>>10895000
               parse'err(errnum := filecommaseminok,parmptr);  <<02663>>10900000
            end;                                               <<02663>>10905000
         end                                                   <<02663>>10910000
      else                                                     <<02663>>10915000
      if parmlen > 6 then   <<invalid volid>>                  <<u.rao>>10920000
         parse'err(errnum := filevolid2long, parmptr)          <<01200>>10925000
      else                                                     <<u.rao>>10930000
         begin                                                 <<u.rao>>10935000
         tos := parms(parmnum-1);                              <<u.rao>>10940000
         delb;   <<pop pointer garbage>>                       <<u.rao>>10945000
         if tos.(10:1) then  <<embedded special character>>    <<u.rao>>10950000
            parse'err(errnum := filevolidspecal, parmptr)      <<01200>>10955000
         else   <<volid ok>>                                   <<u.rao>>10960000
            begin                                              <<u.rao>>10965000
            tapelabellen := parmlen;                           <<u.rao>>10970000
            move tapelabel := bptr,(parmlen);                  <<02663>>10975000
            end;                                               <<u.rao>>10980000
         end;                                                  <<u.rao>>10985000
   if (nextdelim=comma) and (errnum<=0) then                   <<06021>>10990000
      begin   <<type specified?>>                              <<u.rao>>10995000
      tapelabel(tapelabellen) := ",";                          <<u.rao>>11000000
      tapelabellen := tapelabellen+1;                          <<u.rao>>11005000
      getnext;   <<set up for type field>>                     <<u.rao>>11010000
      if parmlen <> 0 then   <<type present>>                  <<u.rao>>11015000
         if parmlen<>3 or parmptr<>"ANS" and parmptr<>"IBM" then        11020000
            parse'err(errnum := fileinvvoltype, parmptr)       <<01200>>11025000
         else  <<valid volume type, save it>>                  <<u.rao>>11030000
            begin                                              <<u.rao>>11035000
            move tapelabel(tapelabellen) := parmptr,(parmlen); <<u.rao>>11040000
            tapelabellen := tapelabellen+parmlen;              <<u.rao>>11045000
            end;   <<of processing of type>>                   <<u.rao>>11050000
      if (nextdelim=comma) and (errnum<=0) then                <<06021>>11055000
         begin   <<check for expiration date>>                 <<u.rao>>11060000
         tapelabel(tapelabellen) := ",";                       <<u.rao>>11065000
         tapelabellen := tapelabellen+1;                       <<u.rao>>11070000
         getnext;  <<set up for expiration date field>>        <<u.rao>>11075000
         if parmlen <> 0 then  <<expiration date field present><<u.rao>>11080000
            if checkexpdate(errnum, parmlen, parmptr,          <<u.rao>>11085000
                      tapelabel(tapelabellen)) then            <<u.rao>>11090000
               tapelabellen := tapelabellen+8;  <<valid exp dat<<u.rao>>11095000
         if (nextdelim=comma) and (errnum<=0) then             <<06021>>11100000
            begin  <<sequence number field specified?>>        <<u.rao>>11105000
            tapelabel(tapelabellen) := ",";                    <<u.rao>>11110000
            tapelabellen := tapelabellen+1;                    <<u.rao>>11115000
            getnext;                                           <<u.rao>>11120000
            if parmlen <> 0 then  <<seq num present>>          <<u.rao>>11125000
               begin                                           <<u.rao>>11130000
               tos := parms(parmnum-1);                        <<u.rao>>11135000
               delb;                                           <<u.rao>>11140000
               if ls0.(10:1) or parmlen>4 then                 <<u.rao>>11145000
                  begin                                        <<u.rao>>11150000
                  parse'err(errnum := filexpinvseq, parmptr);  <<01200>>11155000
                  del;                                         <<u.rao>>11160000
                  end                                          <<u.rao>>11165000
               else if tos.(8:1) and parmptr<>"NEXT" and       <<u.rao>>11170000
                     parmptr<>"ADDF" then  <<ascii in seq field<<u.rao>>11175000
                  parse'err(errnum := filexpinvseq, parmptr)   <<01200>>11180000
               else   <<sequence ok>>                          <<u.rao>>11185000
                  begin                                        <<u.rao>>11190000
                  move tapelabel(tapelabellen) := parmptr,(parmlen);    11195000
                  tapelabellen := tapelabellen+parmlen;        <<u.rao>>11200000
                  end;                                         <<u.rao>>11205000
               end;                                            <<u.rao>>11210000
            end;                                               <<u.rao>>11215000
         end;                                                  <<u.rao>>11220000
      end;                                                     <<u.rao>>11225000
   if errnum <= 0 then                                         <<06021>>11230000
      if (nextdelim=cr) or (nextdelim=semicolon) then          <<u.rao>>11235000
         begin                                                 <<u.rao>>11240000
         checklabeldata := true;                               <<u.rao>>11245000
         while tapelabel(tapelabellen-1) = "," do              <<u.rao>>11250000
            tapelabellen := tapelabellen-1;                    <<u.rao>>11255000
         end                                                   <<u.rao>>11260000
      else   <<extraneous parameter>>                          <<u.rao>>11265000
         begin                                                 <<u.rao>>11270000
         getnext;                                              <<u.rao>>11275000
         parse'err(errnum := filextrnlabel, parmptr);          <<01200>>11280000
         end;                                                  <<u.rao>>11285000
   end;                                                        <<u.rao>>11290000
end;   <<subroutine checklabeldata>>                           <<u.rao>>11295000
                                                               <<u.rao>>11300000
<<                 *********************                   >>  <<u.rao>>11305000
<<                 *     procdisc      *                   >>  <<u.rao>>11310000
<<                 *********************                   >>  <<u.rao>>11315000
                                                               <<u.rao>>11320000
logical subroutine procdisc;                                   <<u.rao>>11325000
begin                                                          <<u.rao>>11330000
procdisc := false;                                             <<u.rao>>11335000
if nextdelim <> equals then  <<missing delimiter before list>> <<u.rao>>11340000
   parse'err(errnum := filereqeqsign, parmptr(parmlen))        <<01200>>11345000
else  <<do sub parameter list>>                                <<u.rao>>11350000
   begin                                                       <<u.rao>>11355000
   if flagfilesize or flagnumexts or flaginitalloc then        <<u.rao>>11360000
      begin <<previously specified, clean up from before, warn><<u.rao>>11365000
      parse'err(-filediscoveride,parmptr);                     <<01200>>11370000
      flagfilesize := false;                                   <<u.rao>>11375000
      flagnumexts := false;                                    <<u.rao>>11380000
      flaginitalloc := false;                                  <<u.rao>>11385000
      end;                                                     <<u.rao>>11390000
   <<first candidate is record size>>                          <<u.rao>>11395000
   getnext;                                                    <<u.rao>>11400000
   if parmlen <> 0 then   <<record size specified>>            <<u.rao>>11405000
      begin                                                    <<u.rao>>11410000
      flagfilesize := true;                                    <<u.rao>>11415000
      filesize := dbinary(parmptr, parmlen);                   <<u.rao>>11420000
      if <> or (filesize <= 0d) then                           <<u.rao>>11425000
         begin                                                 <<u.rao>>11430000
         parse'err(errnum := filefilesize,parmptr);            <<01200>>11435000
         return;   <<bail out>>                                <<u.rao>>11440000
         end;                                                  <<u.rao>>11445000
      end;                                                     <<u.rao>>11450000
   <<next candidate is the number of extents>>                 <<u.rao>>11455000
   if nextdelim = comma then  <<other parms were specified>>   <<u.rao>>11460000
      begin                                                    <<u.rao>>11465000
      getnext;                                                 <<u.rao>>11470000
      if parmlen <> 0 then   <<blocking factor present>>       <<u.rao>>11475000
         begin  <<attempt to parse it>>                        <<u.rao>>11480000
         flagnumexts := true;                                  <<u.rao>>11485000
         numextents := binary(parmptr, parmlen);               <<u.rao>>11490000
         if <> or not(1<=numextents<=32) then                  <<u.rao>>11495000
            begin  <<error in value>>                          <<u.rao>>11500000
            parse'err(errnum := fileextentsprob, parmptr);     <<01200>>11505000
            return                                             <<u.rao>>11510000
            end;                                               <<u.rao>>11515000
         end;                                                  <<u.rao>>11520000
      <<next candidate is the number of initially allocated extents>>   11525000
      if nextdelim = comma then  <<further parms were specified>>       11530000
         begin                                                 <<u.rao>>11535000
         getnext;                                              <<u.rao>>11540000
         if parmlen <> 0 then  <<initial allocation present>>  <<u.rao>>11545000
            begin                                              <<u.rao>>11550000
            flaginitalloc := true;                             <<u.rao>>11555000
            if not flagnumexts then numextents := 32;          <<u.rao>>11560000
            initalloc := binary(parmptr,parmlen);              <<u.rao>>11565000
            if <> or (initalloc > numextents) then             <<u.rao>>11570000
               if parse'only then errnum := fileinitallocbd    <<01200>>11575000
               else cierr(errnum:=fileinitallocbd,parmptr,     <<01200>>11580000
                          %10000,numextents);                  <<01200>>11585000
            end;                                               <<u.rao>>11590000
         end;                                                  <<u.rao>>11595000
      if not buildflag then                                    <<u.rao>>11600000
         begin  <<extent size must fit in 5 bits>>             <<u.rao>>11605000
         numextents := numextents-1;                           <<u.rao>>11610000
         initalloc := initalloc-1;                             <<u.rao>>11615000
         end;                                                  <<u.rao>>11620000
      end;                                                     <<u.rao>>11625000
   if errnum <= 0 then                                         <<06021>>11630000
      if (nextdelim=cr) or (nextdelim=semicolon) then          <<u.rao>>11635000
         procdisc := true                                      <<u.rao>>11640000
      else  <<unknown parameter at end of list>>               <<u.rao>>11645000
         begin                                                 <<u.rao>>11650000
         getnext;                                              <<u.rao>>11655000
         parse'err(errnum := filediscxparms, parmptr);         <<01200>>11660000
         end;                                                  <<u.rao>>11665000
   end;                                                        <<u.rao>>11670000
end;                                                           <<u.rao>>11675000
                                                               <<u.rao>>11680000
<<                 *********************                   >>  <<u.rao>>11685000
<<                 *   checkformmsg    *                   >>  <<u.rao>>11690000
<<                 *********************                   >>  <<u.rao>>11695000
                                                               <<u.rao>>11700000
logical subroutine checkformmsg;                               <<u.rao>>11705000
<<validates and processes forms message>>                      <<u.rao>>11710000
begin                                                          <<u.rao>>11715000
checkformmsg := false;                                         <<u.rao>>11720000
if nextdelim <> equals then  <<missing message>>               <<u.rao>>11725000
   parse'err(errnum := filereqeqsign, parmptr(parmlen))        <<01200>>11730000
else   <<parse formmsg parameter>>                             <<u.rao>>11735000
   begin                                                       <<u.rao>>11740000
   flagforms := true;                                          <<u.rao>>11745000
   if <> then  <<redundantly specified>>                       <<u.rao>>11750000
      parse'err(-fileformoverrid, parmptr);                    <<01200>>11755000
   getnext;                                                    <<u.rao>>11760000
   scan parmptr until [8/%15,8/"."],1;  <<look for ".">>       <<u.rao>>11765000
   if carry then   <<found cr instead>>                        <<u.rao>>11770000
      begin                                                    <<u.rao>>11775000
      parse'err(errnum := filefmsnoperiod, bps0);              <<01200>>11780000
      del;  <<pop pointer on tos>>                             <<u.rao>>11785000
      end                                                      <<u.rao>>11790000
   else  <<message is present, save it>>                       <<u.rao>>11795000
      begin                                                    <<u.rao>>11800000
      formsmsglen := tos-@parmptr;                             <<u.rao>>11805000
      if formsmsglen > 49 then   <<message too long>>          <<u.rao>>11810000
         begin                                                 <<u.rao>>11815000
         parse'err(-filefmstoolong, parmptr(49));              <<01200>>11820000
         formsmsglen := 49;                                    <<u.rao>>11825000
         end;  <<handling of line too long case>>              <<u.rao>>11830000
      formsmsg(formsmsglen) := ".";                            <<u.rao>>11835000
      move formsmsg := parmptr, (formsmsglen);                 <<u.rao>>11840000
      checkformmsg := true;                                    <<u.rao>>11845000
      formsmsglen := formsmsglen+1;  <<for period>>            <<u.rao>>11850000
      index := -1;@bptr := @parmptr;                           <<04179>>11855000
      while bptr(index := index + 1) <> "." do                 <<04179>>11860000
         begin << check for delimiters inside formsmsg >>      <<04179>>11865000
            if bptr(index) = "=" or                            <<04179>>11870000
               bptr(index) = "," or                            <<04179>>11875000
               bptr(index) = ";" then                          <<04179>>11880000
               getnext; << advance to next parameter >>        <<04179>>11885000
         end;                                                  <<04179>>11890000
      end;                                                     <<u.rao>>11895000
   end;                                                        <<u.rao>>11900000
end;   <<subroutine checkformmsg>>                             <<u.rao>>11905000
                                                               <<u.rao>>11910000
<<                 *********************                   >>  <<u.rao>>11915000
<<                 *      procdev      *                   >>  <<u.rao>>11920000
<<                 *********************                   >>  <<u.rao>>11925000
                                                               <<u.rao>>11930000
logical subroutine procdev;                                    <<u.rao>>11935000
<<parses device parameter list.  things to watch out for include>>      11940000
<<1) missing equals sign  2) invalid device name  3) ds line name>>     11945000
<<4) outpri  5) numcopies  6) extraneous parameters.  >>       <<u.rao>>11950000
begin                                                          <<u.rao>>11955000
procdev := false;                                              <<u.rao>>11960000
if nextdelim <> equals then                                    <<u.rao>>11965000
   parse'err(errnum := filereqeqsign, parmptr(parmlen))        <<01200>>11970000
else  <<do sub parameter list>>                                <<u.rao>>11975000
   begin                                                       <<u.rao>>11980000
   if flagadev or flagoutpri or flagnumcopies then             <<01549>>11985000
      begin  <<redundantly specified device parameters>>       <<u.rao>>11990000
      parse'err(-filedevoverride, parmptr); <<warn user>>      <<01200>>11995000
      flagadev := false;                                       <<01549>>12000000
      @dev := @disc & lsl(1); <<reinitialize pointer>>         <<02569>>12005000
      devlen := 0;                                             <<02569>>12010000
      flagoutpri := false;                                     <<u.rao>>12015000
      flagnumcopies := false;                                  <<u.rao>>12020000
      end;                                                     <<u.rao>>12025000
   <<first candidate is the device name>>                      <<u.rao>>12030000
   getnext;                                                    <<u.rao>>12035000
   if parmlen <> 0 then                                        <<u.rao>>12040000
      begin                                                    <<u.rao>>12045000
      flagadev := true;  << got device part >>                 <<02569>>12050000
      if comtype=sysdef then  <<system defined file>>          <<u.rao>>12055000
         begin  <<device system defined>>                      <<u.rao>>12060000
         parse'err(errnum := filesysdefdev, parmptr);          <<01200>>12065000
         return                                                <<u.rao>>12070000
         end;                                                  <<u.rao>>12075000
      @bptr:=@dev:=@parmptr; << set at 1st char of dev >>      <<01117>>12080000
      tos:=parms(parmnum-1); << current parm >>                <<01117>>12085000
      devlen:=parmlen;                                         <<01117>>12090000
      if parmlen > maxdevlen then                              <<04171>>12095000
         begin                                                 <<04171>>12100000
            ddel;                                              <<04171>>12105000
            errnum := filedevname2lng;                         <<04171>>12110000
            flush'command;                                     <<04171>>12115000
                                                               <<04171>>12120000
         end;                                                  <<04171>>12125000
      delb; << delete pointer word >>                          <<01117>>12130000
      if tos.(10:1) then << dev contains specials >>           <<01117>>12135000
         begin                                                 <<01117>>12140000
           move dev := dev while an,1;                         <<04171>>12145000
           stop := false;                                      <<04171>>12150000
           do                                                  <<04171>>12155000
              begin                                            <<04171>>12160000
                 if bps0 = "#" then                            <<04171>>12165000
                    begin                                      <<04171>>12170000
                       if (s0 - @bptr) > maxdevclasslen then   <<04171>>12175000
                          begin                                <<04171>>12180000
                             del;                              <<04171>>12185000
                             errnum := filedsname2long;        <<04171>>12190000
                             flush'command;                    <<04171>>12195000
                                                               <<04171>>12200000
                          end;                                 <<04171>>12205000
                       tos := tos + 1;                         <<04171>>12210000
                       @bptr := s0;                            <<04171>>12215000
                       assemble(dup);                          <<04171>>12220000
                       move * := * while an,1;                 <<04171>>12225000
                    end                                        <<04171>>12230000
                 else                                          <<04171>>12235000
                 if bps0 = " " then                            <<04171>>12240000
                    begin                                      <<04171>>12245000
                       if parmlen > (s0 - @dev) then           <<04171>>12250000
                          begin                                <<04171>>12255000
                             del;                              <<04171>>12260000
                             errnum := fileinvaldevname;       <<04171>>12265000
                             flush'command;                    <<04171>>12270000
                                                               <<04171>>12275000
                          end                                  <<04171>>12280000
                       else                                    <<04171>>12285000
                          begin                                <<04171>>12290000
                             del;                              <<04171>>12295000
                             stop := true;                     <<04171>>12300000
                          end;                                 <<04171>>12305000
                    end                                        <<04171>>12310000
                 else                                          <<04171>>12315000
                 if bps0 = bdelims(nextdelim) then             <<04171>>12320000
                    begin                                      <<04171>>12325000
                       del;                                    <<04171>>12330000
                       stop := true;                           <<04171>>12335000
                    end                                        <<04171>>12340000
                 else                                          <<04171>>12345000
                    begin                                      <<04171>>12350000
                       del;                                    <<04171>>12355000
                       errnum := fileinvaldevname;             <<04171>>12360000
                       flush'command;                          <<04171>>12365000
                                                               <<04171>>12370000
                    end;                                       <<04171>>12375000
              end until stop;                                  <<04171>>12380000
                                                               <<04171>>12385000
        end  << special character inside dev >>                <<04171>>12390000
     else                                                      <<04171>>12395000
        begin                                                  <<04171>>12400000
           if devlen > maxdevclasslen then                              12405000
              begin                                                     12410000
                 errnum := filedevname2lng;                             12415000
                 flush'command;                                         12420000
              end;                                                      12425000
           x := getdevinfo(dev,devinfo) + 1;                   <<04171>>12430000
           case *x of                                          <<04171>>12435000
              begin                                            <<04171>>12440000
                 << virtual device >>                          <<04171>>12445000
                 begin                                         <<04171>>12450000
                    errnum := filevirtualdev;                  <<04171>>12455000
                    flush'command;                             <<04171>>12460000
                 end;                                          <<04171>>12465000
                 << ok >>                                      <<04171>>12470000
                    ;                                          <<04171>>12475000
                 << invalid class >>                           <<04171>>12480000
                 begin                                         <<04171>>12485000
                    errnum := fileinvldclaspec;                <<04171>>12490000
                    flush'command;                             <<04171>>12495000
                 end;                                          <<04171>>12500000
                 << unknown class name >>                      <<04171>>12505000
                 begin                                         <<04171>>12510000
                    errnum := fileunknowndev;                  <<04171>>12515000
                    flush'command;                             <<04171>>12520000
                 end;                                          <<04171>>12525000
                 << unknown logical device number >>           <<04171>>12530000
                 begin                                         <<04171>>12535000
                    errnum := filedontknowldev;                <<04171>>12540000
                    flush'command;                             <<04171>>12545000
                 end;                                          <<04171>>12550000
              end; << case of getdevinfo returns >>            <<04171>>12555000
        end; << device w/o special characters >>               <<04171>>12560000
      end;  <<processing of device name>>                      <<u.rao>>12565000
   if (errnum<=0) and (nextdelim=comma) then                   <<06021>>12570000
      begin  <<more parameters, check for outpri>>             <<u.rao>>12575000
      getnext;                                                 <<u.rao>>12580000
      if (comtype=build) or (comtype=old) or                   <<u.rao>>12585000
            ((comtype=sysdef) land (foptions.defaultdes<>1)) then       12590000
         parse'err(errnum := fileoutprinot, parmptr)           <<01200>>12595000
      else if parmlen <> 0 then  <<outpri evidently specified>><<u.rao>>12600000
         begin                                                 <<u.rao>>12605000
         flagoutpri := true;                                   <<u.rao>>12610000
         outpri := binary(parmptr, parmlen);                   <<u.rao>>12615000
         if <> or not(1<= outpri <= 13) then                   <<u.rao>>12620000
            parse'err(errnum := fileoutpriinvld, parmptr);     <<01200>>12625000
         end;                                                  <<u.rao>>12630000
      if (errnum<=0) and (nextdelim=comma) then                <<06021>>12635000
         begin  <<further parameter(s)>>                       <<u.rao>>12640000
         getnext;                                              <<u.rao>>12645000
         if parmlen <> 0 then   <<numcopies specified>>        <<u.rao>>12650000
            begin                                              <<u.rao>>12655000
            flagnumcopies := true;                             <<u.rao>>12660000
            numcopies := binary(parmptr, parmlen);             <<u.rao>>12665000
            if <> or not(1 <= numcopies <= 127) then           <<u.rao>>12670000
               parse'err(errnum := filenumcopinvld, parmptr);  <<01200>>12675000
            end;                                               <<u.rao>>12680000
         end;  <<numcopies case>>                              <<u.rao>>12685000
      end;  <<spooling parameters>>                            <<u.rao>>12690000
   if errnum <= 0 then                                         <<06021>>12695000
      if (nextdelim=cr) or (nextdelim=semicolon) then          <<u.rao>>12700000
         procdev := true                                       <<u.rao>>12705000
      else                                                     <<u.rao>>12710000
         begin  <<extraneous parameters>>                      <<u.rao>>12715000
         getnext;                                              <<u.rao>>12720000
         parse'err(errnum := filedevxparms, parmptr);          <<01200>>12725000
      end;                                                     <<u.rao>>12730000
   end;                                                        <<u.rao>>12735000
end;  <<subroutine procdev>>                                   <<u.rao>>12740000
                                                               <<u.rao>>12745000
<<                 *********************                   >>  <<u.rao>>12750000
<<                 *      procrec      *                   >>  <<u.rao>>12755000
<<                 *********************                   >>  <<u.rao>>12760000
                                                               <<u.rao>>12765000
logical subroutine procrec;                                    <<u.rao>>12770000
<<syntax  rec=[recsize][,[blockfactor][,[f/v/u][,[binary/ascii]]]]>>    12775000
begin                                                          <<u.rao>>12780000
procrec := false;                                              <<u.rao>>12785000
if nextdelim <> equals then                                    <<u.rao>>12790000
   parse'err(errnum := filereqeqsign, parmptr(parmlen))        <<01200>>12795000
else                                                           <<u.rao>>12800000
   begin  <<parse parameter list>>                             <<u.rao>>12805000
   if flagrecsize or flagblockfactor or flagrecfmt or flagascii then    12810000
      begin  <<redundantly specified, warn, clean up>>         <<u.rao>>12815000
      parse'err(-filerecoverride, parmptr);                    <<01200>>12820000
      flagrecsize := false;                                    <<u.rao>>12825000
      flagblockfactor := false;                                <<u.rao>>12830000
      flagrecfmt := false;                                     <<u.rao>>12835000
      foptions.recordfmt := 0;  <<default to f>>               <<u.rao>>12840000
      flagascii := false;                                      <<u.rao>>12845000
      foptions.asciibinary := 0;  <<default to binary>>        <<u.rao>>12850000
      end;                                                     <<u.rao>>12855000
   <<first candidate is recsize>>                              <<u.rao>>12860000
   getnext;                                                    <<u.rao>>12865000
   if parmlen <> 0 then  <<recsize evidently specified>>       <<u.rao>>12870000
      begin                                                    <<u.rao>>12875000
      flagrecsize := true;                                     <<u.rao>>12880000
      recsize := binary(parmptr, parmlen);                     <<u.rao>>12885000
      if <> or (recsize = 0) then                              <<u.rao>>12890000
         parse'err(errnum := filebadrecsize, parmptr);         <<01200>>12895000
      end;                                                     <<u.rao>>12900000
   if (nextdelim=comma) and (errnum<=0) then                   <<06021>>12905000
      begin <<further parameters to parse>>                    <<u.rao>>12910000
      <<next candidate is the blocking factor>>                <<u.rao>>12915000
      getnext;                                                 <<u.rao>>12920000
      if parmlen <> 0 then  <<blocking factor specified>>      <<u.rao>>12925000
         begin                                                 <<u.rao>>12930000
         flagblockfactor := true;                              <<u.rao>>12935000
         blockfactor := binary(parmptr, parmlen);              <<u.rao>>12940000
         if <> or not (1 <= blockfactor <= 255) then           <<u.rao>>12945000
            parse'err(errnum := filebadblocking, parmptr);     <<01200>>12950000
         end;                                                  <<u.rao>>12955000
      if (nextdelim=comma) and (errnum<=0) then                <<06021>>12960000
         begin  <<further parameters, next is record format>>  <<u.rao>>12965000
         getnext;                                              <<u.rao>>12970000
         if parmlen<>0 then  <<record format specified>>       <<u.rao>>12975000
            begin                                              <<u.rao>>12980000
            flagrecfmt := true;                                <<u.rao>>12985000
            if (parmlen=1) and (parmptr="F") then              <<u.rao>>12990000
               foptions.recordfmt := 0                         <<u.rao>>12995000
            else if (parmlen=1) and (parmptr="V") then         <<u.rao>>13000000
               foptions.recordfmt := 1                         <<u.rao>>13005000
            else if (parmlen=1) and (parmptr="U") then         <<u.rao>>13010000
               foptions.recordfmt := 2                         <<u.rao>>13015000
            else   <<unknown record format>>                   <<u.rao>>13020000
               parse'err(errnum := fileunkrecfmt, parmptr);    <<01200>>13025000
            end;                                               <<u.rao>>13030000
         if (nextdelim=comma) and (errnum<=0) then             <<06021>>13035000
            begin   <<further parameter(s)>>                   <<u.rao>>13040000
            getnext;  <<next candidate is binary/ascii>>       <<u.rao>>13045000
            if parmlen <> 0 then   <<ascii/binary specified>>  <<u.rao>>13050000
               begin                                           <<u.rao>>13055000
               flagascii := true;                              <<u.rao>>13060000
               if (parmlen=5) and (parmptr="ASCII") then       <<u.rao>>13065000
                  foptions.asciibinary := true                 <<u.rao>>13070000
               else if (parmlen=6) and (parmptr="BINARY") then <<u.rao>>13075000
                  foptions.asciibinary := false                <<u.rao>>13080000
               else                                            <<u.rao>>13085000
                  parse'err(errnum:=fileasciiinvald, parmptr); <<01200>>13090000
               end;                                            <<u.rao>>13095000
            end;                                               <<u.rao>>13100000
         end;                                                  <<u.rao>>13105000
      end;                                                     <<u.rao>>13110000
   if errnum <= 0 then                                         <<06021>>13115000
      if (nextdelim=cr) or (nextdelim=semicolon) then          <<u.rao>>13120000
         procrec := true                                       <<u.rao>>13125000
      else  <<extraneous delimiter - unknown parameter?>>      <<u.rao>>13130000
         begin                                                 <<u.rao>>13135000
         getnext;                                              <<u.rao>>13140000
         parse'err(errnum := filerecxtranprm, parmptr);        <<01200>>13145000
         end;                                                  <<u.rao>>13150000
   end;                                                        <<u.rao>>13155000
end;   <<procrec>>                                             <<u.rao>>13160000
                                                               <<u.rao>>13165000
<<                 *********************                   >>  <<u.rao>>13170000
<<                 *     procfcode     *                   >>  <<u.rao>>13175000
<<                 *********************                   >>  <<u.rao>>13180000
                                                               <<u.rao>>13185000
logical subroutine procfcode;                                  <<u.rao>>13190000
begin                                                          <<u.rao>>13195000
if nextdelim <> equals then                                    <<u.rao>>13200000
   parse'err(errnum := filereqeqsign, parmptr(parmlen))        <<01200>>13205000
else                                                           <<u.rao>>13210000
   begin   <<parse parameter>>                                 <<u.rao>>13215000
   getnext;                                                    <<u.rao>>13220000
   flagfilecode := true;                                       <<u.rao>>13225000
   if <> then   <<redundantly specified>>                      <<u.rao>>13230000
      parse'err(-filefcoderedund, parmptr);                    <<01200>>13235000
   if parmlen = 0 then  <<missing, default to 0>>              <<u.rao>>13240000
      begin                                                    <<u.rao>>13245000
      filecode := 0;                                           <<u.rao>>13250000
      parse'err(-filefcodedefalt, parmptr);                    <<01200>>13255000
      end                                                      <<u.rao>>13260000
   else  <<file code parameter present>>                       <<u.rao>>13265000
      begin                                                    <<u.rao>>13270000
      if (parmptr<>numeric) and (parmptr<>"+") and (parmptr<>"-") then  13275000
         begin  <<apparently a named code>>                    <<u.rao>>13280000
         get'filecode(filecode,parmptr,parmlen);               <<01454>>13285000
         if <> then                                            <<01454>>13290000
            parse'err(errnum := fileunkfcode, parmptr);        <<01454>>13295000
         end                                                   <<u.rao>>13300000
      else   <<numeric file code>>                             <<u.rao>>13305000
         begin                                                 <<u.rao>>13310000
         filecode := binary(parmptr, parmlen);                 <<u.rao>>13315000
         if <> or (filecode < 0) then                          <<u.rao>>13320000
            parse'err(errnum := filefcodevalue, parmptr);      <<01200>>13325000
         end;                                                  <<u.rao>>13330000
      end;                                                     <<u.rao>>13335000
   end;                                                        <<u.rao>>13340000
if errnum > 0 then                                             <<06021>>13345000
   procfcode := false                                          <<u.rao>>13350000
else if (nextdelim<>cr) and (nextdelim<>semicolon) then        <<u.rao>>13355000
   begin                                                       <<u.rao>>13360000
   getnext;                                                    <<u.rao>>13365000
   procfcode := false;                                         <<u.rao>>13370000
   parse'err(errnum := filecodextrndel, parmptr);              <<01200>>13375000
   end                                                         <<u.rao>>13380000
else                                                           <<u.rao>>13385000
   procfcode := true;                                          <<u.rao>>13390000
end;  <<procfcode>>                                            <<u.rao>>13395000
                                                               <<u.rao>>13400000
<<                 *********************                   >>  <<u.rao>>13405000
<<                 *    procaccess     *                   >>  <<u.rao>>13410000
<<                 *********************                   >>  <<u.rao>>13415000
                                                               <<u.rao>>13420000
logical subroutine procaccess;                                 <<u.rao>>13425000
begin                                                          <<u.rao>>13430000
if nextdelim <> equals then                                    <<u.rao>>13435000
   parse'err(errnum := filereqeqsign, parmptr(parmlen))        <<01200>>13440000
else                                                           <<u.rao>>13445000
   begin                                                       <<u.rao>>13450000
   move acctypes := pacctypes, (acctypel);                     <<u.rao>>13455000
   flagaccesstype := true;                                     <<u.rao>>13460000
   if <> then                                                  <<u.rao>>13465000
      parse'err(-fileaccessrednd, parmptr);                    <<01200>>13470000
   getnext;                                                    <<u.rao>>13475000
   if parmlen = 0 then  <<access specification required>>      <<u.rao>>13480000
      parse'err(errnum := fileaccreqvalue, parmptr)            <<01200>>13485000
   else                                                        <<u.rao>>13490000
      begin  <<parameter supplied, scan table for it>>         <<u.rao>>13495000
      tos := search(parmptr, parmlen, acctypes) -1;            <<u.rao>>13500000
      if < then  <<unknown access type>>                       <<u.rao>>13505000
         begin                                                 <<u.rao>>13510000
         del;                                                  <<u.rao>>13515000
         parse'err(errnum := fileaccinvalid, parmptr)          <<01200>>13520000
         end                                                   <<u.rao>>13525000
      else                                                     <<u.rao>>13530000
         aoptions.accesstype := tos;  <<ordinal in pacctypes>> <<u.rao>>13535000
      end                                                      <<u.rao>>13540000
   end;                                                        <<u.rao>>13545000
if errnum > 0 then                                             <<06021>>13550000
   procaccess := false                                         <<u.rao>>13555000
else if (nextdelim <> cr) and (nextdelim <> semicolon) then    <<u.rao>>13560000
   begin  <<extraneous parameter or syntax error>>             <<u.rao>>13565000
   getnext;                                                    <<u.rao>>13570000
   procaccess := false;                                        <<u.rao>>13575000
   parse'err(errnum := fileaccxtrnparm, parmptr);              <<01200>>13580000
   end                                                         <<u.rao>>13585000
else                                                           <<u.rao>>13590000
   procaccess := true                                          <<u.rao>>13595000
end;  <<subroutine procaccess>>                                <<u.rao>>13600000
                                                               <<u.rao>>13605000
<<                 *********************                   >>  <<u.rao>>13610000
<<                 *     procfbuf      *                   >>  <<u.rao>>13615000
<<                 *********************                   >>  <<u.rao>>13620000
                                                               <<u.rao>>13625000
logical subroutine procbuf;                                    <<u.rao>>13630000
begin  <<parses buf= parameter>>                               <<u.rao>>13635000
aoptions.nobuf := false;                                       <<u.rao>>13640000
flagbufinhibit := true; <<so nobuf is set false in fopen>>     <<00886>>13645000
if <> then     <<nobuf previously specified>>                  <<u.rao>>13650000
   parse'err(-filenobufbuf,parmptr);                           <<01200>>13655000
numbuffers := 2;  <<default>>                                  <<u.rao>>13660000
flagnumbufs := true;                                           <<u.rao>>13665000
if <> then   <<buf= previously specified>>                     <<u.rao>>13670000
   parse'err(-filebufoverride, parmptr);                       <<01200>>13675000
if nextdelim = equals then   <<number of buffers specified>>   <<u.rao>>13680000
   begin                                                       <<u.rao>>13685000
   getnext;                                                    <<u.rao>>13690000
   if parmlen <> 0 then                                        <<u.rao>>13695000
      begin                                                    <<u.rao>>13700000
      numbuffers := binary(parmptr, parmlen);                  <<u.rao>>13705000
      if <> or not(0 <= numbuffers <= 16) then                 <<u.rao>>13710000
         parse'err(errnum := fileinvldbufnum, parmptr);        <<01200>>13715000
      end                                                      <<u.rao>>13720000
   end;                                                        <<u.rao>>13725000
if errnum > 0 then                                             <<06021>>13730000
   procbuf := false                                            <<u.rao>>13735000
else if (nextdelim<>cr) and (nextdelim<>semicolon) then        <<u.rao>>13740000
   begin <<extraneous parameter>>                              <<u.rao>>13745000
   getnext;                                                    <<u.rao>>13750000
   procbuf := false;                                           <<u.rao>>13755000
   parse'err(errnum := filebufxtrandel, parmptr);              <<01200>>13760000
   end                                                         <<u.rao>>13765000
else                                                           <<u.rao>>13770000
   procbuf := true;                                            <<u.rao>>13775000
end;                                                           <<u.rao>>13780000
                                                               <<01549>>13785000
                                                               <<01549>>13790000
<<                 *********************                   >>  <<01549>>13795000
<<                 *     procenv       *                   >>  <<01549>>13800000
<<                 *********************                   >>  <<01549>>13805000
                                                               <<01549>>13810000
logical subroutine procenv;                                    <<01549>>13815000
<<parses env parameter>>                                       <<01549>>13820000
<<checks for equal sign>>                                      <<01549>>13825000
<<valid filename>>                                             <<01549>>13830000
<< ok if no file name, global env. file will >>                <<01851>>13835000
<< be used by fopen.                         >>                <<01851>>13840000
                                                               <<01549>>13845000
begin                                                          <<01549>>13850000
   procenv := false;                                           <<01549>>13855000
   if nextdelim <> equals then                                 <<01549>>13860000
      parse'err(errnum := filereqeqsign, parmptr(parmlen))     <<01549>>13865000
   else                                                        <<01549>>13870000
      begin                                                    <<01549>>13875000
         if flagenv then                                       <<01549>>13880000
            begin   <<redundantly specified env parm>>         <<01549>>13885000
               parse'err(-fileenvoverride,parmptr);            <<01549>>13890000
               flagenv := false; <<warn user>>                 <<01549>>13895000
            end;                                               <<01549>>13900000
         getnext;                                              <<01851>>13905000
         if parmlen <> 0 then                                  <<01851>>13910000
            if not checkenvfiledesig then                      <<02523>>13915000
               return;                                         <<01851>>13920000
         @env := @parmptr;                                     <<01851>>13925000
         envlen := parmlen;                                    <<01851>>13930000
         flagenv := true;                                      <<01549>>13935000
         if (nextdelim=cr) or (nextdelim=semicolon) then       <<01851>>13940000
            procenv := true                                    <<01851>>13945000
         else                                                  <<01851>>13950000
            begin                                              <<01851>>13955000
               getnext;                                        <<01851>>13960000
               parse'err(errnum:=fileenvxparms,parmptr);       <<01851>>13965000
            end;                                               <<01851>>13970000
         end;                                                  <<01549>>13975000
    end; <<subroutine procenv>>                                <<01549>>13980000
                                                               <<01549>>13985000
                                                               <<01549>>13990000
                                                               <<01549>>13995000
<<                 *********************                   >>  <<01549>>14000000
<<                 *     procoutq      *                   >>  <<01549>>14005000
<<                 *********************                   >>  <<01549>>14010000
                                                               <<01549>>14015000
logical subroutine procoutq;                                   <<01549>>14020000
<<parses outq parameter>>                                      <<01549>>14025000
<<checks for equal sign>>                                      <<01549>>14030000
<<valid alphanumeric outq name up to 8 chars>>                 <<01549>>14035000
<< ok if no outqname, global outq name will >>                 <<01851>>14040000
<< be used by fopen.                        >>                 <<01851>>14045000
                                                               <<01549>>14050000
begin                                                          <<01549>>14055000
                                                               <<01549>>14060000
   procoutq := false;                                          <<01549>>14065000
   if nextdelim <> equals then                                 <<01549>>14070000
      parse'err(errnum := filereqeqsign, parmptr(parmlen))     <<01549>>14075000
   else                                                        <<01549>>14080000
      begin                                                    <<01549>>14085000
         if flagoutq then                                      <<01549>>14090000
         begin  <<redundantly specified outq parm>>            <<01549>>14095000
            parse'err(-fileoutqoverride,parmptr);              <<01549>>14100000
            flagoutq := false;                                 <<01549>>14105000
         end;                                                  <<01549>>14110000
         getnext;                                              <<01549>>14115000
            move parmptr := parmptr while ans;                 <<01549>>14120000
            tos := parms(parmnum-1); <<double for outqname>>   <<01549>>14125000
            delb;  <<pop pointer word>>                        <<01549>>14130000
            if tos.(10:1) then <<outqname contains specials>>  <<01549>>14135000
               parse'err(errnum := outqnamealphnum,parmptr)    <<01549>>14140000
            else                                               <<01549>>14145000
               if parmlen > 8 then                             <<01549>>14150000
               parse'err(errnum := outqname2lng,parmptr)       <<01549>>14155000
            else                                               <<01549>>14160000
               if parmptr = numeric then                       <<01549>>14165000
               parse'err(errnum := outqnamenotalph,parmptr)    <<01549>>14170000
            else                                               <<01549>>14175000
               begin  <<good outq name>>                       <<01549>>14180000
                  @outq := @parmptr;                           <<01851>>14185000
                  outqlen := parmlen;                          <<01851>>14190000
                  flagoutq := true;                            <<01549>>14195000
                  if errnum <= 0 then                          <<06021>>14200000
                     if (nextdelim = cr) or                    <<01549>>14205000
                        (nextdelim = semicolon) then           <<01549>>14210000
                     procoutq := true                          <<01549>>14215000
                     else                                      <<01549>>14220000
                        begin                                  <<01549>>14225000
                           getnext;                            <<01549>>14230000
                           parse'err(errnum := fileoutqxparms, <<01549>>14235000
                                  parmptr);                    <<01549>>14240000
                        end;                                   <<01549>>14245000
               end;                                            <<01549>>14250000
      end;                                                     <<01549>>14255000
end; <<subroutine procoutq>>                                   <<01549>>14260000
                                                               <<01549>>14265000
                                                               <<01549>>14270000
<<                 ********************                    >>  <<02569>>14275000
<<                 *     procdens     *                    >>  <<02569>>14280000
<<                 ********************                    >>  <<02569>>14285000
logical subroutine procdens;                                   <<02569>>14290000
<<parses the den parameter. checks for equal sign followed >>  <<02569>>14295000
<<by an optional density value.                            >>  <<02569>>14300000
<<syntax:   ;den=[1600/6250]                               >>  <<02569>>14305000
begin                                                          <<02569>>14310000
procdens:=false;                                               <<02569>>14315000
if nextdelim <> equals then                                    <<02569>>14320000
  parse'err(errnum:=filereqeqsign,parmptr(parmlen))            <<02569>>14325000
else                                                           <<02569>>14330000
  begin                                                        <<02569>>14335000
     if flagdens then                                          <<02569>>14340000
       begin     <<redundantly specfied dens parm>>            <<02569>>14345000
          parse'err(-filedensoverrid,parmptr);                 <<02569>>14350000
          flagdens := false;   <<warn user>>                   <<02569>>14355000
       end;      <<redundantly specified dens parm>>           <<02569>>14360000
     getnext;    <<look for density value>>                    <<02569>>14365000
     if parmlen <> 0 then                                      <<02569>>14370000
       begin           <<parm found>>                          <<02569>>14375000
          if parse'density(parmptr,parmlen,dummy) then         <<02569>>14380000
             flagdens := true                                  <<02569>>14385000
          else                                                 <<02569>>14390000
             begin      << invalid density subparameter >>     <<02569>>14395000
                parse'err(errnum:=filedensinval,parmptr);      <<02569>>14400000
                flagdens := false;                             <<02569>>14405000
             end;                                              <<02569>>14410000
       end             <<parm found>>                          <<02569>>14415000
     else flagdens := true;    <<default case>>                <<02569>>14420000
     if flagdens then        << good parm >>                   <<02569>>14425000
       begin                                                   <<02569>>14430000
          @dens := @parmptr;                                   <<02569>>14435000
          denslen := parmlen;                                  <<02569>>14440000
          if errnum <= 0 then                                  <<06021>>14445000
            if (nextdelim = cr) or (nextdelim = semicolon)     <<02569>>14450000
              then procdens := true                            <<02569>>14455000
            else begin                                         <<02569>>14460000
                 getnext;                                      <<02569>>14465000
                 parse'err(errnum:=filedensxparm,parmptr);     <<02569>>14470000
                 end;                                          <<02569>>14475000
       end;     <<good parm>>                                  <<02569>>14480000
  end;                                                         <<02569>>14485000
end;      << subroutine procdens >>                            <<02569>>14490000
                                                               <<02569>>14495000
                                                               <<02569>>14500000
<<                 *********************                   >>  <<u.rao>>14505000
<<                 *      prockey      *                   >>  <<u.rao>>14510000
<<                 *********************                   >>  <<u.rao>>14515000
                                                               <<u.rao>>14520000
logical subroutine prockey;                                    <<u.rao>>14525000
<<processes the parameter list.  note that it is only called       >>   14530000
<<if it appears that a parameter list is present.  in general      >>   14535000
<<this routine only controls the parse;  anything which is even    >>   14540000
<<moderately complex (i.e, has parameters) is done in a further    >>   14545000
<<subroutine.  in essence, we must do four things in this routine. >>   14550000
<<1)  identify the parameters which are not appropriate to this    >>   14555000
<<    form of the command.                                         >>   14560000
<<2)  control the scan through the parameter list.  (done with     >>   14565000
<<    a do loop around a case statement.                           >>   14570000
<<3)  process trivial parameters like wait, nomr and a few others  >>   14575000
<<    which simply involve setting a few bits somewhere.           >>   14580000
<<4)  look for extraneous subparameters on the trivial parameters. >>   14585000
<<another thing to note is that for the most part we allow the     >>   14590000
<<user to specify a parameter redundantly, using the latest        >>   14595000
<<occurrence as the controlling one.                               >>   14600000
begin                                                          <<u.rao>>14605000
prockey := false;                                              <<u.rao>>14610000
move keylist := pkeylist, (pkeylistl);                         <<u.rao>>14615000
<<now get comtype.  comtype is an integer indicating which >>  <<u.rao>>14620000
<<type of command this is.                                 >>  <<u.rao>>14625000
if buildflag then                                              <<u.rao>>14630000
   comtype := build                                            <<u.rao>>14635000
else if foptions.defaultdes = 0 then  <<regular filereference>><<u.rao>>14640000
   if foptions.domain = 0 then                                 <<u.rao>>14645000
      comtype := new                                           <<u.rao>>14650000
   else                                                        <<u.rao>>14655000
      comtype := old                                           <<u.rao>>14660000
else if foptions.defaultdes = 2 then <<$newpass>>              <<u.rao>>14665000
   comtype := new                                              <<u.rao>>14670000
else if foptions.defaultdes = 3 then  <<$oldpass>>             <<u.rao>>14675000
   comtype := old                                              <<u.rao>>14680000
else   <<$stdin, $stdlist, $stdinx>>                           <<u.rao>>14685000
   comtype := sysdef;                                          <<u.rao>>14690000
<<now do body of keyword processing>>                          <<u.rao>>14695000
do    <<until error or end of parameters>>                     <<u.rao>>14700000
   begin                                                       <<u.rao>>14705000
   getnext;  <<set up next keyword>>                           <<u.rao>>14710000
   if parmlen = 0 then  <<doubled delimiter>>                  <<u.rao>>14715000
      parse'err(-fileextrandelim, parmptr)                     <<01200>>14720000
   else   <<non-blank string>>                                 <<u.rao>>14725000
      begin   <<identify keyword>>                             <<u.rao>>14730000
      tos := search(parmptr, parmlen, keylist, dictptr);       <<u.rao>>14735000
      <<before processing, check to see that this keyword is>> <<u.rao>>14740000
      <<appropriate for this particular version of the command><<u.rao>>14745000
      if (s0 <> 0)  <<valid key name>>   and                   <<u.rao>>14750000
         (((1&lsl(comtype)) land logical(dictptr)) <> 0) then  <<u.rao>>14755000
         begin  <<keyword out of context>>                     <<u.rao>>14760000
         del;  <<pop ordinal of keyword>>                      <<u.rao>>14765000
         <<fixup keyword to be parameter to genmsg>>           <<u.rao>>14770000
         tos := parmptr(parmlen);                              <<u.rao>>14775000
         parmptr(x) := 0;                                      <<u.rao>>14780000
         case *comtype of                                      <<u.rao>>14785000
            begin                                              <<u.rao>>14790000
            if parse'only then errnum := filecontxtbld         <<01200>>14795000
            else                                               <<01200>>14800000
               cierr(errnum:=filecontxtbld,parmptr,0,@parmptr);<<01200>>14805000
                                                               <<01200>>14810000
            if parse'only then errnum := filecontxtsysdf       <<01200>>14815000
            else                                               <<01200>>14820000
               cierr(errnum:=filecontxtsysdf,parmptr,0,        <<01200>>14825000
                     @parmptr);                                <<01200>>14830000
                                                               <<01200>>14835000
            if parse'only then errnum := filecontxtold         <<01200>>14840000
            else                                               <<01200>>14845000
               cierr(errnum:=filecontxtold,parmptr,0,@parmptr);<<01200>>14850000
                                                               <<01200>>14855000
            if parse'only then errnum := filecontxtnew         <<01200>>14860000
            else                                               <<01200>>14865000
               cierr(errnum:=filecontxtnew,parmptr,0,@parmptr);<<01200>>14870000
            end;                                               <<u.rao>>14875000
         parmptr(parmlen) := tos;                              <<u.rao>>14880000
         return                                                <<u.rao>>14885000
         end;                                                  <<u.rao>>14890000
      <<we know that this keyword is appropriate to this>>     <<u.rao>>14895000
      <<form of the file or build command.  now actually process>>      14900000
      <<the keyword>>                                          <<u.rao>>14905000
      case *tos of                                             <<u.rao>>14910000
         begin                                                 <<u.rao>>14915000
            begin  <<unknown keyword>>                         <<u.rao>>14920000
            if buildflag then                                  <<u.rao>>14925000
               parse'err(errnum := bldunknownkey, parmptr)     <<01200>>14930000
            else   <<file command>>                            <<u.rao>>14935000
               parse'err(errnum := fileunknownkey, parmptr);   <<01200>>14940000
            return;                                            <<u.rao>>14945000
            end;                                               <<u.rao>>14950000
                                                               <<u.rao>>14955000
            <<dev = >>                                         <<u.rao>>14960000
            if not procdev then return;                        <<u.rao>>14965000
                                                               <<u.rao>>14970000
            <<disc = >>                                        <<u.rao>>14975000
            if not procdisc then return;                       <<u.rao>>14980000
                                                               <<u.rao>>14985000
            <<rec = >>                                         <<u.rao>>14990000
            if not procrec then return;                        <<u.rao>>14995000
                                                               <<u.rao>>15000000
            <<file code>>                                      <<u.rao>>15005000
            if not procfcode then return;                      <<u.rao>>15010000
                                                               <<u.rao>>15015000
            <<cctl>>                                           <<u.rao>>15020000
            begin                                              <<u.rao>>15025000
               foptions.cctl := true;   <<also checks previous state>>  15030000
               if = and flagcctl then   <<inconsistent with and >>      15035000
                  parse'err(-filenocctlcctl, parmptr);         <<01200>>15040000
               flagcctl := true;                               <<u.rao>>15045000
            end;                                               <<u.rao>>15050000
                                                               <<u.rao>>15055000
            <<nocctl>>                                         <<u.rao>>15060000
            begin                                              <<u.rao>>15065000
               foptions.cctl := false;                         <<u.rao>>15070000
               if <> then   <<inconsistent with previous cctl>><<u.rao>>15075000
                  parse'err(-filecctlnocctl, parmptr);         <<01200>>15080000
               flagcctl := true;                               <<u.rao>>15085000
            end;                                               <<u.rao>>15090000
                                                               <<u.rao>>15095000
            <<temp>>                                           <<u.rao>>15100000
            begin                                              <<u.rao>>15105000
               flagdisp := true;                               <<u.rao>>15110000
               if <> then  <<possible contradiction>>          <<u.rao>>15115000
                  if disposition = delete then                 <<u.rao>>15120000
                     parse'err(-filedeltemp, parmptr)          <<01200>>15125000
                  else if disposition = save then              <<u.rao>>15130000
                     parse'err(-filesavetemp, parmptr);        <<01200>>15135000
               disposition := temp;                            <<u.rao>>15140000
            end;                                               <<u.rao>>15145000
                                                               <<u.rao>>15150000
            <<save>>                                           <<u.rao>>15155000
            begin                                              <<u.rao>>15160000
               flagdisp := true;                               <<u.rao>>15165000
               if <> then  <<possible conflict with previous spec>>     15170000
                  if disposition = delete then                 <<u.rao>>15175000
                     parse'err(-filedelsave, parmptr)          <<01200>>15180000
                  else if disposition = temp then              <<u.rao>>15185000
                     parse'err(-filetempsave, parmptr);        <<01200>>15190000
               disposition := save;                            <<u.rao>>15195000
            end;                                               <<u.rao>>15200000
                                                               <<u.rao>>15205000
            <<del>>                                            <<u.rao>>15210000
            begin                                              <<u.rao>>15215000
               flagdisp := true;                               <<u.rao>>15220000
               if <> then  <<possible inconsistency with previous>>     15225000
                  if disposition  = temp then                  <<u.rao>>15230000
                     parse'err(-filetempdel, parmptr)          <<01200>>15235000
                  else if disposition = save then              <<u.rao>>15240000
                     parse'err(-filesavedel, parmptr);         <<01200>>15245000
               disposition := delete;                          <<u.rao>>15250000
            end;                                               <<u.rao>>15255000
                                                               <<u.rao>>15260000
            <<access>>                                         <<u.rao>>15265000
            if not procaccess then return;                     <<u.rao>>15270000
                                                               <<u.rao>>15275000
            <<share>>                                          <<u.rao>>15280000
            begin                                              <<u.rao>>15285000
               flagexclusive := true;                          <<u.rao>>15290000
               if <> then                                      <<u.rao>>15295000
                  if aoptions.exclaccess = exclusive then      <<u.rao>>15300000
                     parse'err(-fileexclshare, parmptr)        <<01200>>15305000
                  else if aoptions.exclaccess = exclusiveread then      15310000
                     parse'err(-fileexclshare,parmptr);        <<01549>>15315000
               aoptions.exclaccess := share;                   <<u.rao>>15320000
            end;                                               <<u.rao>>15325000
                                                               <<u.rao>>15330000
            <<ear>>                                            <<u.rao>>15335000
            begin                                              <<u.rao>>15340000
               flagexclusive := true;                          <<u.rao>>15345000
               if <> then                                      <<u.rao>>15350000
                  if aoptions.exclaccess = exclusive then      <<u.rao>>15355000
                     parse'err(-fileexclear, parmptr)          <<01200>>15360000
                  else if aoptions.exclaccess = share then     <<u.rao>>15365000
                     parse'err(-fileshareear, parmptr);        <<01200>>15370000
               aoptions.exclaccess := exclusiveread;           <<u.rao>>15375000
            end;                                               <<u.rao>>15380000
                                                               <<01549>>15385000
            <<semi>>                                           <<01549>>15390000
            begin                                              <<01549>>15395000
               flagexclusive := true;                          <<01549>>15400000
               if <> then                                      <<01549>>15405000
                  if aoptions.exclaccess = exclusive then      <<01549>>15410000
                     parse'err(-fileexclsemi,parmptr)          <<01549>>15415000
                  else if aoptions.exclaccess = share then     <<01549>>15420000
                     parse'err(-filesharesemi,parmptr);        <<01549>>15425000
               aoptions.exclaccess := exclusiveread;           <<01549>>15430000
            end;                                               <<01549>>15435000
                                                               <<01549>>15440000
                                                               <<u.rao>>15445000
            <<exc>>                                            <<u.rao>>15450000
            begin                                              <<u.rao>>15455000
               flagexclusive := true;                          <<u.rao>>15460000
               if <> then                                      <<u.rao>>15465000
                  if aoptions.exclaccess = exclusiveread then  <<u.rao>>15470000
                     parse'err(-fileearexcl, parmptr)          <<01200>>15475000
                  else if aoptions.exclaccess = share then     <<u.rao>>15480000
                     parse'err(-fileshareexcl, parmptr);       <<01200>>15485000
               aoptions.exclaccess := exclusive;               <<u.rao>>15490000
            end;                                               <<u.rao>>15495000
                                                               <<u.rao>>15500000
            <<buf = >>                                         <<u.rao>>15505000
            if not procbuf then return;                        <<u.rao>>15510000
                                                               <<u.rao>>15515000
            <<nobuf>>                                          <<u.rao>>15520000
            begin                                              <<u.rao>>15525000
               aoptions.nobuf := true;                         <<u.rao>>15530000
               flagnumbufs := false;  << in case previous buf= <<u.rao>>15535000
               if <> then  <<was a previous buf = parameter>>  <<u.rao>>15540000
                  parse'err(-filebufnobuf, parmptr);           <<01200>>15545000
               flagbufinhibit := true;  <<inhibit buffering>>  <<u.rao>>15550000
            end;                                               <<u.rao>>15555000
            <<copy>>                                           <<01549>>15560000
            begin                                              <<01549>>15565000
               aoptions.copy := true;                          <<01549>>15570000
               if = and flagcopy then                          <<01549>>15575000
                  parse'err(-filenocopycopy, parmptr);         <<01549>>15580000
               flagcopy := true;                               <<01549>>15585000
            end;                                               <<01549>>15590000
                                                               <<01549>>15595000
            <<nocopy>>                                         <<01549>>15600000
            begin                                              <<01549>>15605000
               aoptions.copy := false;                         <<01549>>15610000
               if <> then   <<inconsistent with previous copy>><<01549>>15615000
                  parse'err(-filecopynocopy, parmptr);         <<01549>>15620000
               flagcopy := true;                               <<01549>>15625000
            end;                                               <<01549>>15630000
                                                               <<01549>>15635000
                                                               <<u.rao>>15640000
            <<mr>>                                             <<u.rao>>15645000
            begin                                              <<u.rao>>15650000
               aoptions.multirecord := true;                   <<u.rao>>15655000
               if = and flagmultirec then                      <<u.rao>>15660000
                  parse'err(-filenomrmr, parmptr);             <<01200>>15665000
               flagmultirec := true;                           <<u.rao>>15670000
            end;                                               <<u.rao>>15675000
                                                               <<u.rao>>15680000
            <<nomr>>                                           <<u.rao>>15685000
            begin                                              <<u.rao>>15690000
               aoptions.multirecord := false;                  <<u.rao>>15695000
               if <> then   <<inconsistent with previous mr>>  <<u.rao>>15700000
                  parse'err(-filemrnomr, parmptr);             <<01200>>15705000
               flagmultirec := true;                           <<u.rao>>15710000
            end;                                               <<u.rao>>15715000
                                                               <<u.rao>>15720000
            <<global multiaccess>>                             <<01549>>15725000
            begin                                              <<01549>>15730000
            flagmultiaccess:=true;                             <<01549>>15735000
            if <> then                                         <<01549>>15740000
               case aoptions.multiaccess of                    <<01549>>15745000
                  begin                                        <<01549>>15750000
                  parse'err(-filenomultgmult, parmptr);        <<01549>>15755000
                  parse'err(-filemultigmulti, parmptr);        <<01549>>15760000
                  end;                                         <<01549>>15765000
            aoptions.multiaccess:=globalmulti;                 <<01549>>15770000
            end;                                               <<01549>>15775000
            <<local multiaccess>>                              <<01549>>15780000
            begin                                              <<01549>>15785000
            flagmultiaccess:=true;                             <<01549>>15790000
            if <> then                                         <<01549>>15795000
               case aoptions.multiaccess of                    <<01549>>15800000
                  begin                                        <<01549>>15805000
                  parse'err(-filenomultimulti, parmptr);       <<01549>>15810000
                  ;  <<already was set to local>>              <<01549>>15815000
                  parse'err(-filegmultimulti, parmptr);        <<01549>>15820000
                  end;                                         <<01549>>15825000
            aoptions.multiaccess:=localmulti;                  <<01549>>15830000
            end;                                               <<01549>>15835000
                                                               <<01549>>15840000
            <<no multiaccess>>                                 <<01549>>15845000
            begin                                              <<01549>>15850000
            flagmultiaccess:=true;                             <<01549>>15855000
            if <> then                                         <<01549>>15860000
               case aoptions.multiaccess of                    <<01549>>15865000
                  begin                                        <<01549>>15870000
                  ;  <<already set to no multiaccess>>         <<01549>>15875000
                  parse'err(-filemultinomulti, parmptr);       <<01549>>15880000
                  parse'err(-filegmultnomult, parmptr);        <<01549>>15885000
                  end;                                         <<01549>>15890000
            aoptions.multiaccess:=nomulti;                     <<01549>>15895000
            end;                                               <<01549>>15900000
            <<nolabel>>                                        <<u.rao>>15905000
            begin                                              <<u.rao>>15910000
               foptions.tapelabelf := false;                   <<u.rao>>15915000
               if <> then  <<inconsistently specified>>        <<u.rao>>15920000
                  begin                                        <<u.rao>>15925000
                  parse'err(-filelabelnolabel, parmptr);       <<01200>>15930000
                  tapelabellen := 0;  <<reset>>                <<u.rao>>15935000
                  end;                                         <<u.rao>>15940000
               flaglabeledtape := true;                        <<01099>>15945000
            end;                                               <<u.rao>>15950000
                                                               <<u.rao>>15955000
            <<forms>>                                          <<u.rao>>15960000
            if not checkformmsg then return;                   <<u.rao>>15965000
                                                               <<u.rao>>15970000
            <<label=>>                                         <<u.rao>>15975000
            if not checklabeldata then return;                 <<u.rao>>15980000
                                                               <<u.rao>>15985000
            <<lock>>                                           <<u.rao>>15990000
            begin                                              <<u.rao>>15995000
               aoptions.locking := true;                       <<u.rao>>16000000
               if = and flagdynlocking then                    <<u.rao>>16005000
                  parse'err(-filenolocklock, parmptr);         <<01200>>16010000
               flagdynlocking := true;                         <<u.rao>>16015000
            end;                                               <<u.rao>>16020000
                                                               <<u.rao>>16025000
            <<nolock>>                                         <<u.rao>>16030000
            begin                                              <<u.rao>>16035000
               aoptions.locking := false;                      <<04.ro>>16040000
               if <> then   <<inconsistent>>                   <<u.rao>>16045000
                  parse'err(-filelocknolock, parmptr);         <<01200>>16050000
               flagdynlocking := true;                         <<u.rao>>16055000
            end;                                               <<u.rao>>16060000
                                                               <<u.rao>>16065000
            <<wait>>                                           <<u.rao>>16070000
            begin                                              <<u.rao>>16075000
               aoptions.nowait := false;                       <<u.rao>>16080000
               if <> then                                      <<u.rao>>16085000
                  parse'err(-filenowaitwait, parmptr);         <<01200>>16090000
               flagwait := true;                               <<u.rao>>16095000
            end;                                               <<u.rao>>16100000
                                                               <<u.rao>>16105000
            <<nowait>>                                         <<u.rao>>16110000
            begin                                              <<u.rao>>16115000
               aoptions.nowait := true;                        <<u.rao>>16120000
               if = and flagwait then                          <<u.rao>>16125000
                  parse'err(-filewaitnowait, parmptr);         <<01200>>16130000
               flagwait := true;                               <<u.rao>>16135000
            end;                                               <<u.rao>>16140000
                                                               <<01549>>16145000
            <<std>>                                            <<01549>>16150000
            begin                                              <<01549>>16155000
            flagftype:=true;                                   <<01549>>16160000
            if <> then                                         <<01549>>16165000
               case foptions.filetype of                       <<01549>>16170000
                  begin                                        <<01549>>16175000
                  ;  <<already set to std>>                    <<01549>>16180000
                  ;  <<ksam -- cannot be>>                     <<01549>>16185000
                  parse'err(-fileriostd, parmptr);             <<01549>>16190000
                  ;                                            <<01549>>16195000
                  parse'err(-filecirstd, parmptr);             <<01549>>16200000
                  ;                                            <<01549>>16205000
                  parse'err(-filemsgstd, parmptr);             <<01549>>16210000
                  end;                                         <<01549>>16215000
            foptions.filetype:=std;                            <<01549>>16220000
            end;                                               <<01549>>16225000
                                                               <<01549>>16230000
            <<rio>>                                            <<01549>>16235000
            begin                                              <<01549>>16240000
            flagftype:=true;                                   <<01549>>16245000
            if <> then                                         <<01549>>16250000
               case foptions.filetype of                       <<01549>>16255000
                  begin                                        <<01549>>16260000
                  parse'err(-filestdrio, parmptr);             <<01549>>16265000
                  ;  <<ksam -- cannot be>>                     <<01549>>16270000
                  ;  <<already set to rio>>                    <<01549>>16275000
                  ;                                            <<01549>>16280000
                  parse'err(-filecirrio, parmptr);             <<01549>>16285000
                  ;                                            <<01549>>16290000
                  parse'err(-filemsgrio, parmptr);             <<01549>>16295000
                  end;                                         <<01549>>16300000
            foptions.filetype:=rio;                            <<01549>>16305000
            end;                                               <<01549>>16310000
                                                               <<01549>>16315000
            <<norio>>                                          <<01549>>16320000
            begin                                              <<01549>>16325000
            flagftype:=true;                                   <<01549>>16330000
            if <> then                                         <<01549>>16335000
               case foptions.filetype of                       <<01549>>16340000
                  begin                                        <<01549>>16345000
                  ;  <<already set to std>>                    <<01549>>16350000
                  ;  <<ksam -- cannot be>>                     <<01549>>16355000
                  parse'err(-fileriostd, parmptr);             <<01549>>16360000
                  ;                                            <<01549>>16365000
                  parse'err(-filecirstd, parmptr);             <<01549>>16370000
                  ;                                            <<01549>>16375000
                  parse'err(-filemsgstd, parmptr);             <<01549>>16380000
                  end;                                         <<01549>>16385000
            foptions.filetype:=std;                            <<01549>>16390000
            end;                                               <<01549>>16395000
                                                               <<01549>>16400000
                                                               <<01549>>16405000
            <<env>>                                            <<01549>>16410000
            if not procenv then return;                        <<01549>>16415000
                                                               <<01549>>16420000
            <<outq>>                                           <<01549>>16425000
            if not procoutq then return;                       <<01549>>16430000
                                                               <<01549>>16435000
            <<msg>>                                            <<01549>>16440000
            begin                                              <<01549>>16445000
            flagftype:=true;                                   <<01549>>16450000
            if <> then                                         <<01549>>16455000
               case foptions.filetype of                       <<01549>>16460000
                  begin                                        <<01549>>16465000
                  parse'err(-filestdmsg, parmptr);             <<01549>>16470000
                  ;  <<ksam -- cannot be>>                     <<01549>>16475000
                  parse'err(-fileriomsg, parmptr);             <<01549>>16480000
                  ;                                            <<01549>>16485000
                  parse'err(-filecirmsg, parmptr);             <<01549>>16490000
                  end;                                         <<01549>>16495000
            foptions.filetype:=msg;                            <<01549>>16500000
            end;                                               <<01549>>16505000
                                                               <<01549>>16510000
            <<cir>>                                            <<01549>>16515000
            begin                                              <<01549>>16520000
            flagftype:=true;                                   <<01549>>16525000
            if <> then                                         <<01549>>16530000
               case foptions.filetype of                       <<01549>>16535000
                  begin                                        <<01549>>16540000
                  parse'err(-filestdcir, parmptr);             <<01549>>16545000
                  ;  <<ksam -- cannot be>>                     <<01549>>16550000
                  parse'err(-fileriocir, parmptr);             <<01549>>16555000
                  ;                                            <<01549>>16560000
                  ;  <<already set to circular>>               <<01549>>16565000
                  ;                                            <<01549>>16570000
                  parse'err(-filemsgcir, parmptr);             <<01549>>16575000
                  end;                                         <<01549>>16580000
            foptions.filetype:=cir;                            <<01549>>16585000
            end;                                               <<01549>>16590000
                                                               <<01549>>16595000
                                                               <<u.rao>>16600000
            << den >>                                          <<02569>>16605000
            if not procdens then return;                       <<02569>>16610000
                                                               <<02569>>16615000
         end;  <<of case>>                                     <<u.rao>>16620000
      end;  <<of else clause>>                                 <<u.rao>>16625000
   end                                                         <<u.rao>>16630000
      until nextdelim <> semicolon;                            <<u.rao>>16635000
                                                               <<u.rao>>16640000
<<parse terminated because the next delimiter indicated that  ><<u.rao>>16645000
<<what followed was not a keyword.  if it was not a carriage  ><<u.rao>>16650000
<<return then there was a syntax error.  since all of the     ><<u.rao>>16655000
<<parsers of keywords with subparameters are responsible for  ><<u.rao>>16660000
<<checking for extraneous or unexpected delimiters, the only  ><<u.rao>>16665000
<<time the next delimiter would not be a carriage return would><<u.rao>>16670000
<<be after one of the keywords which has no qualifiers.       ><<u.rao>>16675000
if nextdelim <> cr then                                        <<u.rao>>16680000
   begin  <<handle extraneous delimiters>>                     <<u.rao>>16685000
   <<first fixup so parameter name can be passed to cierr>>    <<u.rao>>16690000
   tos := @parmptr;                                            <<u.rao>>16695000
   tos := bps0(parmlen);                                       <<u.rao>>16700000
   bps1(x) := 0;                                               <<u.rao>>16705000
   getnext;                                                    <<u.rao>>16710000
   if parse'only then errnum := filenoxpctsparm                <<01200>>16715000
   else                                                        <<01200>>16720000
      cierr(errnum := filenoxpctsparm, parmptr, 0, @bps1);     <<01200>>16725000
   bps1(x) := tos;  <<restore previous value over 0>>          <<u.rao>>16730000
   del;  <<pop pointer>>                                       <<u.rao>>16735000
   end                                                         <<u.rao>>16740000
else                                                           <<u.rao>>16745000
   prockey := true;                                            <<u.rao>>16750000
end;  <<subroutine prockey>>                                   <<u.rao>>16755000
                                                               <<u.rao>>16760000
<<                 *********************                   >>  <<u.rao>>16765000
<<                 *     main body     *                   >>  <<u.rao>>16770000
<<                 *********************                   >>  <<u.rao>>16775000
                                                               <<u.rao>>16780000
<<main body of file command>>                                  <<u.rao>>16785000
<<this code does three things, parse the file name part, invoke<<u.rao>>16790000
<<the parse of any keywords which might be present, and do the><<u.rao>>16795000
<<call to the routine which sets up the jdt entry.>>           <<u.rao>>16800000
<<note that when a failure is detected, this procedure is exited>>      16805000
<<immediately.>>                                               <<u.rao>>16810000
                                                               <<01200>>16815000
<< normal entry point for :file command >>                     <<01255>>16820000
parse'only := false;                                           <<01200>>16825000
goto startparse;                                               <<01200>>16830000
                                                               <<01200>>16835000
<< parse'file'eq is an entry point to perform only the parse >><<01200>>16840000
<< of a file equation.  the parsed file equation table is    >><<01200>>16845000
<< not added to the jdt but rather returned to the caller    >><<01200>>16850000
<< through the 1st parameter of the call.                    >><<01200>>16855000
parse'file'eq:                                                 <<01200>>16860000
parse'only := true;                                            <<01200>>16865000
                                                               <<01200>>16870000
startparse:                                                    <<01200>>16875000
parmnum := 0;                                                  <<u.rao>>16880000
move savedcomimage := parmsp,(cis'bcombuflen);                 << i.a >>16885000
mycommand(parmsp,,maxparms+1,numparms,parms);                  <<u.rao>>16890000
if numparms=0 then  <<lacks required formal file designator>>  <<u.rao>>16895000
   begin                                                       <<u.rao>>16900000
   parmnum := 1;                                               <<u.rao>>16905000
   cierr(errnum := filereqfdesig,parmsp(1));                   <<u.rao>>16910000
   return;                                                     <<u.rao>>16915000
   end;                                                        <<u.rao>>16920000
<<first step is to parse the formal file designator>>          <<u.rao>>16925000
if not checkfdesig then return;                                <<u.rao>>16930000
<<have valid formal file designator.  now look for actual fdesig.>>     16935000
if numparms=1 then <<requires at least one other parm>>        <<u.rao>>16940000
   begin                                                       <<u.rao>>16945000
   cierr(errnum := filereqsomeparm,formaldes(parmlen));        <<u.rao>>16950000
   return                                                      <<u.rao>>16955000
   end;                                                        <<u.rao>>16960000
if nextdelim=equals then   <<actual designator promised>>      <<u.rao>>16965000
   if not checkadesig then return;                             <<u.rao>>16970000
<<check for file domain>>                                      <<u.rao>>16975000
if nextdelim=comma then   <<domain promised>>                  <<u.rao>>16980000
   if not checkdomain then return;                             <<u.rao>>16985000
<<the only legal thing after this is the keyword list, if any>>         16990000
if (nextdelim<>cr) and (nextdelim<>semicolon) then             <<u.rao>>16995000
   begin  <<unexpected delimiters, syntax error>>              <<u.rao>>17000000
   getnext;                                                    <<u.rao>>17005000
   parse'err(errnum := filexstrtparmcr, parmptr(-1));          <<01200>>17010000
   return                                                      <<u.rao>>17015000
   end;                                                        <<u.rao>>17020000
<<now have name info completely parsed.>>                      <<u.rao>>17025000
                                                               <<u.rao>>17030000
<<next step is the parse of the parameter list, if present.>>  <<u.rao>>17035000
if nextdelim = semicolon then  <<some parameters evidently exist>>      17040000
   if not prockey then return;                                 <<u.rao>>17045000
                                                               <<u.rao>>17050000
<<at this point we have parsed the entire command.  if we made it   >>  17055000
<<this far, there are no obvious problems.  all parameters have been>>  17060000
<<put into the appropriate forms and saved in local variables by the>>  17065000
<<appropriate names.  it remains but to build the entry and         >>  17070000
<<insert it in the job directory table.                             >>  17075000
parmnum := 0;                                                  <<u.rao>>17080000
                                                               <<02569>>17085000
<< device flag set only if one of the components is present >> <<02569>>17090000
flagdev := flagadev lor flagdens lor flagenv lor flagoutq;     <<02569>>17095000
                                                               <<02569>>17100000
wentry := flags1;  <<pmask word 1>>                            <<u.rao>>17105000
wentry(1) := flags2;  <<second word of pmask>>                 <<u.rao>>17110000
wentry(2) := 0;   <<name and device length and keyword len>>   <<01549>>17115000
if flaganame then  <<actual designator present>>               <<u.rao>>17120000
   begin                                                       <<u.rao>>17125000
   bentry(4) := actualdeslen;                                  <<u.rao>>17130000
   move bentry(nextentryx) := actualdes, (actualdeslen);       <<u.rao>>17135000
   nextentryx := nextentryx+integer(actualdeslen);             <<u.rao>>17140000
   end;                                                        <<u.rao>>17145000
if flagdev then                                                <<02569>>17150000
   begin           << some device info specified >>            <<02569>>17155000
   if flagadev then                                            <<02569>>17160000
      begin        << device name specified >>                 <<02569>>17165000
   move bentry(nextentryx) := dev, (devlen);                   <<u.rao>>17170000
   nextentryx := nextentryx+devlen;                            <<u.rao>>17175000
      end;                                                     <<02569>>17180000
   if flagdens then                                            <<02569>>17185000
      begin                                                    <<02569>>17190000
          move bentry(nextentryx) := ";DEN=";                  <<02569>>17195000
          nextentryx := nextentryx + 5;                        <<02569>>17200000
          move bentry(nextentryx) := dens, (denslen);          <<02569>>17205000
          nextentryx := nextentryx + denslen;                  <<02569>>17210000
          keys'len := keys'len + denslen + 5;                  <<02569>>17215000
      end;                                                     <<02569>>17220000
   if flagenv then                                             <<01851>>17225000
      begin                                                    <<01851>>17230000
         move bentry(nextentryx) := ";ENV=";                   <<01851>>17235000
         nextentryx := nextentryx + 5;                         <<01851>>17240000
         move bentry(nextentryx) := env,(envlen);              <<01851>>17245000
         nextentryx := nextentryx + envlen;                    <<01851>>17250000
         keys'len := keys'len + envlen + 5;                    <<02569>>17255000
      end;                                                     <<01851>>17260000
   if flagoutq then                                            <<01851>>17265000
      begin                                                    <<01851>>17270000
         move bentry(nextentryx) := ";OUTQ=";                  <<01851>>17275000
         nextentryx := nextentryx + 6;                         <<01851>>17280000
         move bentry(nextentryx) := outq,(outqlen);            <<01851>>17285000
         nextentryx := nextentryx + outqlen;                   <<01851>>17290000
         keys'len := keys'len + outqlen + 6;                   <<01851>>17295000
      end;                                                     <<01851>>17300000
   if keys'len <> 0 then                                       <<01851>>17305000
      begin                                                    <<01851>>17310000
         keys'len := keys'len + 1;                             <<01851>>17315000
         bentry(nextentryx) := %15;                            <<01851>>17320000
         nextentryx := nextentryx + 1;                         <<01851>>17325000
      end;                                                     <<01851>>17330000
   bentry(5) := devlen + keys'len;                             <<01851>>17335000
   end;                                                        <<u.rao>>17340000
<<this ends the variable portions of the wentry>>              <<u.rao>>17345000
x := (nextentryx+1)&lsr(1);  <<word offset from wentry base>>  <<u.rao>>17350000
wentry(x) := foptions;                                         <<u.rao>>17355000
wentry(x:=x+1) := aoptions;                                    <<u.rao>>17360000
tos := numbuffers&lsl(8);                                      <<u.rao>>17365000
tos.(8:5) := initalloc;                                        <<u.rao>>17370000
wentry(x:=x+1) := tos lor logical(disposition);                <<u.rao>>17375000
wentry(x:=x+1) := recsize;                                     <<u.rao>>17380000
wentry(x:=x+1) := logical(numextents)&lsl(11) lor logical(blockfactor); 17385000
tos := filesize;                                               <<u.rao>>17390000
assemble(xch);                                                 <<u.rao>>17395000
wentry(x:=x+1) := tos;  <<first word of filesize>>             <<u.rao>>17400000
wentry(x:=x+1) := tos;  <<second word>>                        <<u.rao>>17405000
wentry(x:=x+1) := filecode;                                    <<u.rao>>17410000
wentry(x:=x+1) := (logical(outpri)&lsl(7)lor logical(numcopies))&lsl(5);17415000
      wentry(x:=x+1) := 0;  <<user labels count>>              <<u.rao>>17420000
      wentry(x:=x+1) := 0; << mpev native language support>>   <<06566>>17425000
      wentry(x:=x+1) := formsmsglen + tapelabellen;            <<u.rao>>17430000
      if wentry(x) <> 0 then                                   <<u.rao>>17435000
         begin  <<move in optional data>>                      <<u.rao>>17440000
         tos := (@wentry(x)+1)&lsl(1);  <<byte address>>       <<u.rao>>17445000
         if formsmsglen<>0 then   <<move in forms message>>    <<u.rao>>17450000
            move * := formsmsg, (formsmsglen), 2;              <<u.rao>>17455000
         if tapelabellen<>0 then   <<move in tape label data>> <<u.rao>>17460000
            begin                                              <<u.rao>>17465000
            if formsmsglen=0 then   <<must insert ".">>        <<u.rao>>17470000
               begin                                           <<u.rao>>17475000
               bps0 := ".";                                    <<u.rao>>17480000
               tos := tos+1;                                   <<u.rao>>17485000
               wentry(x) := wentry(x)+1;                       <<u.rao>>17490000
               formsmsglen := 1;                               <<u.rao>>17495000
               end;                                            <<u.rao>>17500000
            move * := tapelabel,(tapelabellen),2;              <<u.rao>>17505000
            bps0 := ";";                                       <<u.rao>>17510000
            wentry(x) := wentry(x)+1;                          <<u.rao>>17515000
            tapelabellen := tapelabellen+1;                    <<u.rao>>17520000
            end;                                               <<u.rao>>17525000
         del;                                                  <<u.rao>>17530000
         x := x+(formsmsglen+tapelabellen+1)&lsr(1);           <<u.rao>>17535000
         end;                                                  <<u.rao>>17540000
if parse'only then                                             <<01200>>17545000
   begin                                                       <<01200>>17550000
   << copy local table entry over the string passed to     >>  <<01200>>17555000
   << parse'file'eq.  this returns the parsed file         >>  <<01200>>17560000
   << equation info to the caller.                         >>  <<01200>>17565000
   x := (x+1) * 2;                                             <<01200>>17570000
   move parmsp := bentry, (x);                                 <<01200>>17575000
   end                                                         <<01200>>17580000
else                                                           <<01200>>17585000
   begin                                                       <<01200>>17590000
   << add table entry to jdt >>                                <<01200>>17595000
   if addjtentry(formaldes,group,acct,-3,x+1,wentry) <> 0 then <<01200>>17600000
      cierr(errnum := feqtabfullxplct);  << insert failed >>   <<01200>>17605000
   end;                                                        <<01200>>17610000
return;                                                        <<u.rao>>17615000
                                                               <<u.rao>>17620000
<<  ***  end of cxfile  ***   >>                               <<u.rao>>17625000
                                                               <<u.rao>>17630000
<<  ***   cxbuild   ***  >>                                    <<u.rao>>17635000
cxbuild:                                                       <<u.rao>>17640000
                                                               <<u.rao>>17645000
<<this differs from the procedure for the file command primarily>>      17650000
<<in that we do an fopen instead of calling jobtables.          >>      17655000
                                                               <<u.rao>>17660000
buildflag := true;                                             <<u.rao>>17665000
parse'only := false;                                           <<01255>>17670000
foptions := %2000;   <<disallows file equates  >>              <<u.rao>>17675000
parmnum := 0;                                                  <<u.rao>>17680000
mycommand(parmsp,,maxparms+1,numparms,parms);                  <<u.rao>>17685000
if numparms=0 then  <<lacks required file name>>               <<u.rao>>17690000
   begin                                                       <<u.rao>>17695000
   parmnum := 1;                                               <<u.rao>>17700000
   cierr(errnum := bldreqfilename, parmsp(1));                 <<u.rao>>17705000
   end                                                         <<u.rao>>17710000
else if bldcheckfdesig then  <<file name is valid>>            <<u.rao>>17715000
if nextdelim=comma then   <<domain not appropriate>>           <<u.rao>>17720000
   begin                                                       <<u.rao>>17725000
   getnext;                                                    <<u.rao>>17730000
   cierr(errnum := blddomainnot,parmptr);                      <<u.rao>>17735000
   end                                                         <<u.rao>>17740000
else if nextdelim=equals then  <<actual designator not appropriate>>    17745000
   begin                                                       <<u.rao>>17750000
   getnext;                                                    <<u.rao>>17755000
   cierr(errnum := bldnotades,parmptr);                        <<u.rao>>17760000
   end                                                         <<u.rao>>17765000
else  <<name seems ok>>                                        <<u.rao>>17770000
   begin                                                       <<u.rao>>17775000
   if nextdelim=semicolon then  <<apparently keyword list follows>>     17780000
      if not prockey then   <<parse of keyword list failed>>   <<u.rao>>17785000
         return;                                               <<u.rao>>17790000
   <<now just do build - fopen, followed by fclose>>           <<u.rao>>17795000
   savedelim := dev(devlen);                                   <<02053>>17800000
   dev(devlen) := %15; <<get'dev'parms will not get confused >><<01835>>17805000
   if filecode = 1090 then                                     <<00506>>17810000
      begin                                                    <<00506>>17815000
      blockfactor:=32;                                         <<00506>>17820000
      foptions.(13:1):=1;                                      <<00506>>17825000
      recsize:=-256;                                           <<00506>>17830000
      if numextents <= 0 then numextents:=1;                   <<00506>>17835000
      tos:=filesize:=filesize+double(blockfactor);             <<00506>>17840000
      filesize:=filesize/double(blockfactor*numextents);       <<00506>>17845000
      tos:=numextents*blockfactor;                             <<00506>>17850000
      assemble(divl);                                          <<00506>>17855000
      if tos <> 0 then filesize:=filesize+1d;                  <<00506>>17860000
      assemble(del);                                           <<00506>>17865000
      filesize:=filesize*double((blockfactor)*numextents);     <<00506>>17870000
      filesize:=filesize-double(blockfactor);                  <<00506>>17875000
      flagblockfactor:=1;                                      <<00506>>17880000
      end;                                                     <<00506>>17885000
   tos := 0;  <<return space for fopen>>                       <<u.rao>>17890000
   tos := @formaldes;                                          <<u.rao>>17895000
   tos := foptions;                                            <<u.rao>>17900000
   tos := %100;   <<exclusive access>>                         <<u.rao>>17905000
   tos := recsize;                                             <<u.rao>>17910000
   tos := @dev;                                                <<u.rao>>17915000
   tos := 0;  <<forms message>>                                <<u.rao>>17920000
   tos := 0;   <<user labels>>                                 <<u.rao>>17925000
   tos := blockfactor;                                         <<u.rao>>17930000
   tos := 1;   <<number of buffers for open>>                  <<u.rao>>17935000
   tos := filesize;                                            <<u.rao>>17940000
   tos := numextents;                                          <<u.rao>>17945000
   tos := initalloc;                                           <<u.rao>>17950000
   tos := filecode;                                            <<u.rao>>17955000
   <<now do option variable mask>>                             <<u.rao>>17960000
   tos := %16020;   <<prototype spl option var mask>>          <<u.rao>>17965000
   tos.(6:1)  := flagrecsize;                                  <<u.rao>>17970000
   tos.(7:1)  := flagadev;                                     <<02569>>17975000
   tos.(10:1) := flagblockfactor;                              <<u.rao>>17980000
   tos.(12:1) := flagfilesize;                                 <<u.rao>>17985000
   tos.(13:1) := flagnumexts;                                  <<u.rao>>17990000
   tos.(14:1) := flaginitalloc;                                <<u.rao>>17995000
   tos.(15:1) := flagfilecode;                                 <<u.rao>>18000000
   <<mask is complete, all parms stacked.>>                    <<u.rao>>18005000
   assemble(pcal dfopen);                                      <<00200>>18010000
   if carry then                                               <<u.rao>>18015000
      begin  <<open failed on new file>>                       <<u.rao>>18020000
      ferror'(*, parmnum);                                     <<u.rao>>18025000
      qualifyfilename(formaldes, bentry);                      <<u.rao>>18030000
      cierr(errnum := bldfailed,,0,@bentry);                   <<u.rao>>18035000
      end                                                      <<u.rao>>18040000
   else                                                        <<u.rao>>18045000
      begin  <<try close>>                                     <<u.rao>>18050000
      fclose(s0,disposition,0);                                <<u.rao>>18055000
      if carry then                                            <<u.rao>>18060000
         begin                                                 <<u.rao>>18065000
         ferror'(*,parmnum);                                   <<u.rao>>18070000
         qualifyfilename(formaldes,bentry);                    <<u.rao>>18075000
         cierr(errnum := bldfailed,,0,@bentry);                <<u.rao>>18080000
         end;                                                  <<u.rao>>18085000
      end;                                                     <<u.rao>>18090000
   dev(devlen) := savedelim;                                   <<02053>>18095000
   end;                                                        <<u.rao>>18100000
end;   <<procedure cxfile/cxbuild>>                            <<u.rao>>18105000
$page "FILE MANAGEMENT COMMAND EXECUTORS--RESET,SAVE,PURGE,RENAME"      18110000
$control    segment  =  cifilem                                         18115000
                                                                        18120000
      procedure cxreset executorhead;                                   18125000
      option privileged,uncallable;                                     18130000
      begin                                                             18135000
<< reset, creset commands:  if a particular equate is to be >> <<u.rao>>18140000
<< reset, then find it in the jdt, remove it and contract the>><<u.rao>>18145000
<< table.  if all are to be reset, just delete the table.   >> <<u.rao>>18150000
      double array parms(0:1) =q;                              <<u.rao>>18155000
      byte pointer badparm = parms+2;                          <<u.rao>>18160000
      logical lbadparm = badparm;                              <<u.rao>>18165000
      array qarray(*) = q + 0;                                 <<06567>>18170000
      integer pcbglobloc;                                      <<06567>>18175000
      integer numparms;                                        <<u.rao>>18180000
      integer                                                           18185000
        jdtend = db+6,                                         <<u.rao>>18190000
        jdtjcw = db+5,    <<job control table>>                <<u.rao>>18195000
         jdtlineeq=db+4,                                                18200000
         jdtfileeq=db+3;                                                18205000
                                                                        18210000
      array                                                             18215000
        jdtjcwarr(@) = db+5,  <<points to jcw table>>          <<u.rao>>18220000
         jdtline(@) = db+4,                                             18225000
         jdtfile(@) = db+3;                                             18230000
      logical blank := "  ";  <<for bpntr>>                    <<u.rao>>18235000
<<>>                                                           <<u.rao>>18240000
      logical x2 = parms+1;                                    <<u.rao>>18245000
      logical gpntr := 0;                                      <<u.rao>>18250000
      logical apntr := 0;                                      <<u.rao>>18255000
      byte pointer group=gpntr,bpntr:=@blank,accnt=apntr,formdes=parms; 18260000
      integer tnum;                                                     18265000
      entry cxcreset;                                                   18270000
                                                                        18275000
      if false then                                                     18280000
         begin                                                          18285000
cxcreset:                                                               18290000
         tnum := 4;           <<line equation table>>                   18295000
         end else tnum := 3;  <<file equation table>>                   18300000
      mycommand(parmsp,,2,numparms,parms);                     <<u.rao>>18305000
      if <> or numparms=0 then                                 <<u.rao>>18310000
         begin  <<parameter specification error>>              <<u.rao>>18315000
         if = then parmnum := 1 else parmnum := 2;             <<u.rao>>18320000
         tos := errnum := (if tnum=3 then resetparmerr         <<u.rao>>18325000
                                     else cresetparmerr);      <<u.rao>>18330000
         if parmnum = 1 then tos := @parmsp(1)                 <<u.rao>>18335000
                        else tos := @formdes;                  <<u.rao>>18340000
         cierr(*,*);                                           <<u.rao>>18345000
         return                                                <<u.rao>>18350000
         end;                                                  <<u.rao>>18355000
      if formdes="@" and x2=%443 then                          <<u.rao>>18360000
         begin<<all files eliminated>>                                  18365000
         tos := lockjir;<<lock down job sir>>                           18370000
         pxglobal;                                             <<06567>>18375000
         exchangedb(pxg'jdtdst);                               <<06567>>18380000
         if tnum = 3 then                                               18385000
         <<:file reset>>                                                18390000
         if jdtfileeq <> jdtlineeq then                                 18395000
         begin                                                          18400000
            move jdtfile := jdtline,(jdtend-jdtlineeq);                 18405000
            jdtend := jdtend-jdtlineeq+jdtfileeq;              <<u.rao>>18410000
            jdtjcw := jdtjcw-jdtlineeq+jdtfileeq;              <<u.rao>>18415000
            jdtlineeq := jdtfileeq;                                     18420000
         end else else                                                  18425000
         <<:cline reset>>                                               18430000
            begin   <<move jcw table up>>                      <<u.rao>>18435000
            move jdtline := jdtjcwarr,(jdtend-jdtjcw);         <<u.rao>>18440000
            jdtend := jdtend-jdtjcw+jdtlineeq;                 <<u.rao>>18445000
            jdtjcw := jdtlineeq;                               <<u.rao>>18450000
            end;                                               <<u.rao>>18455000
         exchangedb(0);                                                 18460000
         unlockjir (*);                                                 18465000
         end                                                            18470000
      else                                                              18475000
         begin<<individual file>>                                       18480000
        tos:=checkfilename'(parms&lsr(8),gpntr,apntr,lbadparm);<<u.rao>>18485000
         if < then  <<problem parsing file name>>              <<u.rao>>18490000
            begin                                              <<u.rao>>18495000
            parmnum := 1;                                      <<u.rao>>18500000
            errnum := s0;                                      <<u.rao>>18505000
            cierr(*,badparm);                                  <<u.rao>>18510000
            end                                                <<u.rao>>18515000
         else if > then   <<system defined file>>              <<u.rao>>18520000
            begin                                              <<u.rao>>18525000
            parmnum := 1;                                      <<u.rao>>18530000
            cierr(errnum := reqformalfdesig, formdes);         <<u.rao>>18535000
            end                                                <<u.rao>>18540000
         else                                                  <<u.rao>>18545000
            begin                                              <<u.rao>>18550000
            <<have valid formal file designator. it now remains<<u.rao>>18555000
            <<to attempt to remove this file equate>>          <<u.rao>>18560000
            if gpntr = 0 then gpntr := @bpntr; <<set to blank>><<u.rao>>18565000
            if apntr = 0 then apntr := @bpntr;                 <<u.rao>>18570000
            if xremjtentry(formdes,group,accnt,tnum) <> 0 then <<u.rao>>18575000
               begin                                           <<u.rao>>18580000
               tos := if tnum=3 then errnum := -feqnotfound    <<04785>>18585000
                               else errnum := -errlnotfound;   <<04785>>18590000
               cierr(*,formdes);                               <<u.rao>>18595000
               end;                                            <<u.rao>>18600000
            end;                                               <<u.rao>>18605000
         end;                                                  <<u.rao>>18610000
      end;<<cxreset>>                                                   18615000
procedure cxrename executorhead;                                        18620000
   option privileged, uncallable;                                       18625000
begin                                                                   18630000
logical dl := %26015;  <<comma, cr>>                           <<u.rao>>18635000
integer numparms;                                              <<u.rao>>18640000
double array parms(0:3)=q;                                     <<u.rao>>18645000
byte pointer oldfname = parms;                                 <<u.rao>>18650000
byte oldfnamelen = parms+1;                                    <<u.rao>>18655000
byte pointer newfname = parms+2;                               <<u.rao>>18660000
byte pointer tempparm = parms+4;                               <<u.rao>>18665000
byte tempparmlen = parms+5;                                    <<u.rao>>18670000
byte pointer errptr = parms+6;                                 <<u.rao>>18675000
integer foptions := %2001;  <<old perm., disallow file eq.>>   <<u.rao>>18680000
byte array fullfilename(0:35);                                 <<u.rao>>18685000
                                                               <<u.rao>>18690000
mycommand(parmsp,dl,4,numparms,parms);                         <<u.rao>>18695000
if numparms > 3 then                                           <<u.rao>>18700000
   begin  <<too many parameters>>                              <<u.rao>>18705000
   parmnum := 4;                                               <<u.rao>>18710000
   cierr(errnum := rename2mp, errptr);                         <<u.rao>>18715000
   end                                                         <<u.rao>>18720000
else if numparms=0 then                                        <<u.rao>>18725000
   begin  <<expected old file name>>                           <<u.rao>>18730000
   parmnum := 1;                                               <<u.rao>>18735000
   cierr(errnum := renamereqoldname, parmsp(1));               <<u.rao>>18740000
   end                                                         <<u.rao>>18745000
else if numparms=1 then                                        <<u.rao>>18750000
   begin  <<expected new file name>>                           <<u.rao>>18755000
   parmnum := 2;                                               <<u.rao>>18760000
   cierr(errnum := renamereqnewname, oldfname(oldfnamelen));   <<u.rao>>18765000
   end                                                         <<u.rao>>18770000
else if cibadfilename(errnum,parms) then                       <<u.rao>>18775000
   parmnum := 1  <<first file name failed to parse>>           <<u.rao>>18780000
else if cibadfilename(errnum,parms(1)) then                    <<u.rao>>18785000
   parmnum := 2                                                <<u.rao>>18790000
else                                                           <<u.rao>>18795000
   begin                                                       <<u.rao>>18800000
   <<we know that we have at least two good parms.  now we>>   <<u.rao>>18805000
   <<start getting to the heart of the matter>>                <<u.rao>>18810000
   if numparms = 3 then  <<check for "TEMP">>                  <<u.rao>>18815000
      if (tempparmlen <> 4) or (tempparm <> "TEMP") then       <<u.rao>>18820000
         begin                                                 <<u.rao>>18825000
         parmnum := 3;                                         <<u.rao>>18830000
         cierr(errnum := renameexpecttemp,tempparm);           <<u.rao>>18835000
         return                                                <<u.rao>>18840000
         end                                                   <<u.rao>>18845000
      else                                                     <<u.rao>>18850000
         foptions := %2002;  <<old temp, disallow file eq.>>   <<u.rao>>18855000
   tos := fopen(oldfname,foptions,%10500); <<nobuf,exc,ksam>>  <<06.ro>>18860000
   if carry then  <<open on old file failed>>                  <<u.rao>>18865000
      begin                                                    <<u.rao>>18870000
      ferror'(*,parmnum);                                      <<u.rao>>18875000
      qualifyfilename(oldfname,fullfilename);                  <<u.rao>>18880000
      cierr(errnum := renameoldffserr,,0,@fullfilename);       <<u.rao>>18885000
      end                                                      <<u.rao>>18890000
   else  <<open succeeded>>                                    <<u.rao>>18895000
      begin   <<try new name>>                                 <<u.rao>>18900000
      frename(s0,newfname);                                    <<u.rao>>18905000
      if carry then   <<rename failed>>                        <<u.rao>>18910000
         begin                                                 <<u.rao>>18915000
         ferror'(*,parmnum);                                   <<u.rao>>18920000
         cierr(errnum := renamefailed);                        <<u.rao>>18925000
         end                                                   <<u.rao>>18930000
      else   <<now just close the newly named file>>           <<u.rao>>18935000
         begin                                                 <<u.rao>>18940000
         fclose(s0,0,0);                                       <<u.rao>>18945000
         if carry then   <<close somehow failed>>              <<u.rao>>18950000
            begin                                              <<u.rao>>18955000
            ferror'(*,parmnum);                                <<u.rao>>18960000
            cierr(errnum := renameclsfailed);                  <<u.rao>>18965000
            end;                                               <<u.rao>>18970000
         end;                                                  <<u.rao>>18975000
      end;                                                     <<u.rao>>18980000
   end;                                                        <<u.rao>>18985000
end;                                                           <<u.rao>>18990000
procedure cxpurge executorhead;                                         18995000
   option privileged, uncallable;                                       19000000
begin                                                                   19005000
double dl := [8/",",8/";",8/%15,8/0]d;  <<delimiters>>         <<u.rao>>19010000
equate                                                         <<u.rao>>19015000
   semi = 1;                                                   << i.a >>19020000
integer numparms;                                              <<u.rao>>19025000
integer fcheckcode = numparms;                                 <<u.rao>>19030000
double array parms(0:2) = q;                                   <<u.rao>>19035000
byte pointer filename = parms;                                 <<u.rao>>19040000
byte filenamelen = parms+1;                                    <<u.rao>>19045000
logical filedata = parms+1;                                    <<u.rao>>19050000
byte pointer tempparm = parms+2;                               <<u.rao>>19055000
byte tempparmlen = parms+3;                                    <<u.rao>>19060000
byte pointer extraparm = parms+4;                              <<u.rao>>19065000
byte array tempfilename(0:35);  <<for error reporting>>        <<u.rao>>19070000
logical foptions := %2001;   <<old perm, disallow file eq.>>   <<u.rao>>19075000
equate delete = 4,                                             <<u.rao>>19080000
       aoptions = %10501;                                      <<u.rao>>19085000
define delimiter=filedata.(11:5)#;                             <<u.rao>>19090000
                                                               <<u.rao>>19095000
mycommand(parmsp,dl,3,numparms,parms);                         <<u.rao>>19100000
if numparms > 2 then                                           <<u.rao>>19105000
   begin  <<too many parameters>>                              <<u.rao>>19110000
   parmnum := 3;                                               <<u.rao>>19115000
   cierr(errnum := purge2mp, filename );                       <<06020>>19120000
   end                                                         <<u.rao>>19125000
else if numparms = 0 then                                      <<u.rao>>19130000
   begin <<too few parameters>>                                <<u.rao>>19135000
   parmnum := 1;                                               <<u.rao>>19140000
   cierr(errnum := purgereqfname, parmsp(1));                  <<u.rao>>19145000
   end                                                         <<u.rao>>19150000
else if cibadfilename(errnum,parms) then                       <<u.rao>>19155000
   parmnum := 1                                                <<u.rao>>19160000
else                                                           <<u.rao>>19165000
   begin                                                       <<u.rao>>19170000
   <<check separating delimiter>>                              <<u.rao>>19175000
   if delimiter=semi then                                      <<u.rao>>19180000
      cierr(errnum := -purgesemicolon,  filename(filenamelen));<<04785>>19185000
   <<have valid file name.  check for "TEMP">>                 <<u.rao>>19190000
   if numparms = 2 then  <<expect "TEMP">>                     <<u.rao>>19195000
      if (tempparmlen<>4) or (tempparm<>"TEMP") then           <<u.rao>>19200000
         begin                                                 <<u.rao>>19205000
         parmnum := 2;                                         <<u.rao>>19210000
         cierr(errnum := purgeexpecttemp, tempparm);           <<u.rao>>19215000
         return                                                <<u.rao>>19220000
         end                                                   <<u.rao>>19225000
      else                                                     <<u.rao>>19230000
         foptions := %2002;  <<old temp, disallow file eq.>>   <<u.rao>>19235000
   tos :=dfopen(filename,foptions,aoptions);                   <<00200>>19240000
   if carry then  <<open failed>>                              <<u.rao>>19245000
      begin                                                    <<u.rao>>19250000
      fcheck(s0,fcheckcode);                                   <<u.rao>>19255000
      if fcheckcode<>52 and fcheckcode<>53 and fcheckcode<>58  <<u.rao>>19260000
         then                                                  <<u.rao>>19265000
         begin   <<serious purge error>>                       <<u.rao>>19270000
         ferror'(*,parmnum);                                   <<u.rao>>19275000
         qualifyfilename(filename,tempfilename);               <<u.rao>>19280000
         cierr(errnum := purgefopenfaild,,0,@tempfilename);    <<u.rao>>19285000
         end                                                   <<u.rao>>19290000
      else                                                     <<u.rao>>19295000
         begin                                                 <<u.rao>>19300000
         qualifyfilename(filename,tempfilename);               <<u.rao>>19305000
         cierr(errnum := -purgefnotfound,filename,0,           <<04785>>19310000
     @tempfilename);                                           <<04785>>19315000
         end                                                   <<u.rao>>19320000
      end                                                      <<u.rao>>19325000
   else                                                        <<u.rao>>19330000
      begin <<good open>>                                      <<u.rao>>19335000
      fclose(s0,delete,0);                                     <<u.rao>>19340000
      if carry then                                            <<u.rao>>19345000
         begin  <<close failed>>                               <<u.rao>>19350000
         ferror'(*,parmnum);                                   <<u.rao>>19355000
         qualifyfilename(filename,tempfilename);               <<u.rao>>19360000
         cierr(errnum := purgeclosefaild,,0,@tempfilename);    <<u.rao>>19365000
         end;                                                  <<u.rao>>19370000
      end;                                                     <<u.rao>>19375000
   end;                                                        <<u.rao>>19380000
end;  <<cxpurge>>                                              <<u.rao>>19385000
procedure makefn(fn);                                          <<04784>>19390000
byte array fn; <<minimum of 9 characters >>                    <<04784>>19395000
option privileged,uncallable;                                  <<*7882>>19400000
begin                                                          <<04784>>19405000
<<*********************************************************>>  <<04784>>19410000
<<                                                         >>  <<04784>>19415000
<<                 m a k e f n                             >>  <<04784>>19420000
<<*********************************************************>>  <<04784>>19425000
comment.                                                       <<04784>>19430000
  this procedure will use the chronos intrinsics to generate   <<04784>>19435000
a file name which is used by the save command to temporarily   <<04784>>19440000
create a file to save $oldpass to to avoid the problem of      <<04784>>19445000
running into duplicate temporary file names.  this file        <<04784>>19450000
will be used to rename $oldpass to and then saved as a         <<04784>>19455000
permanent file, and later renamed again to the desired file    <<04784>>19460000
name specified by the user.                                    <<04784>>19465000
chronos return the following three words:                      <<04784>>19470000
       00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15         <<04784>>19475000
word 1:last 2 digits of yr : day of year (julian seq)  :       <<04784>>19480000
word 2:          hour         :        minute          :       <<04784>>19485000
word 3:        second         :   tenths of seconds    :       <<04784>>19490000
       00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15         <<04784>>19495000
this routine places the character "S" in the first position    <<04784>>19500000
of the output string, the julian day of the year into pos-     <<04784>>19505000
ition one through three (converted into characters). minutes   <<04784>>19510000
into four and five.  and seconds into six and seven, and a     <<04784>>19515000
blank into eight                                               <<04784>>19520000
      0      1    2     3     4     5     6     7     8        <<04784>>19525000
  :   s   :   julian day   :  hours    :  minutes  : blank :   <<04784>>19530000
      0      1    2     3     4     5     6     7     8        <<04784>>19535000
a secondary entry point makefn' is used whenever duplicate     <<04784>>19540000
names occur.  in this circumstance as attempt is make to stay  <<04784>>19545000
within the same day and hour by incrementing minutes from the  <<04784>>19550000
value 60.  if this fails the hour is reset and incremented     <<04784>>19555000
beginning with the value 24.  should this fail the day is      <<04784>>19560000
reset and all value are incremented beginning with the value   <<04784>>19565000
367 for the day, 00 for the hour and 00, for the minute.  as   <<04784>>19570000
a last resort the day, hour, minute string is reset to zero.   <<04784>>19575000
;                                                              <<04784>>19580000
<<*********************************************************>>  <<04784>>19585000
   long dtgl;                                                  <<04784>>19590000
   array dtg(*)=dtgl;                                          <<04784>>19595000
   double dtgc=dtgl+1;                                         <<04784>>19600000
   byte array dtgb(*)=dtgl;                                    <<04784>>19605000
   integer                                                     <<04784>>19610000
      i,                                                       <<04784>>19615000
      day,                                                     <<04784>>19620000
      hour,                                                    <<04784>>19625000
      minute;   << used by makefn' >>                          <<04784>>19630000
   entry makefn';                                              <<04784>>19635000
   move fn := "S0000000 ";  << housekeep >>                    <<04784>>19640000
   dtg := calendar;  <<year-day  replaces upper part >>        <<04784>>19645000
                     << of chronos                   >>        <<04784>>19650000
   dtgc := clock;    <<hour-minute-second-fraction   >>        <<04784>>19655000
                     << lower part.                  >>        <<04784>>19660000
   i := 1; <<conversion position index for julian day>>        <<04784>>19665000
   if dtg.(7:9) < 10 then                                      <<04784>>19670000
      i := 3                                                   <<04784>>19675000
   else                                                        <<04784>>19680000
      if dtg.(7:9) <100 then                                   <<04784>>19685000
         i := 2;                                               <<04784>>19690000
   ascii(dtg.(7:9),10,fn(i));  << convert day  >>              <<04784>>19695000
   i := if dtg(1).(0:8) < 10 then 5 else 4; <<adjust hour >>   <<04784>>19700000
                                            <<index       >>   <<04784>>19705000
   if dtgb(2) <> 0 then                                        <<04784>>19710000
      ascii(dtg(1).(0:8),10,fn(i)); <<hour <> zero  >>         <<04784>>19715000
   i := if dtg(1).(8:8) < 10 then 7 else 6; <<adjust minute>>  <<04784>>19720000
                                            <<index        >>  <<04784>>19725000
   if dtgb(3) <> 0 then                                        <<04784>>19730000
      ascii(dtg(1).(8:8),10,fn(i)); << minute <> 0  >>         <<04784>>19735000
   return;  << normal entry >>                                 <<04784>>19740000
                                                               <<04784>>19745000
makefn':                                                       <<04784>>19750000
   << secondary entry for duplicate names  >>                  <<04784>>19755000
   day := binary(fn(1),3);   <<convert received values >>      <<04784>>19760000
   hour := binary(fn(4),2);                                    <<04784>>19765000
   minute := binary(fn(6),2);                                  <<04784>>19770000
   if minute < 60 then                                         <<04784>>19775000
      begin   << build phony minute number >>                  <<04784>>19780000
      move fn(6) := "60";                                      <<04784>>19785000
      return;                                                  <<04784>>19790000
      end;                                                     <<04784>>19795000
   if minute < 99 then                                         <<04784>>19800000
      begin  << build phony minute number  >>                  <<04784>>19805000
      minute := minute + 1;                                    <<04784>>19810000
      ascii(minute,10,fn(6));                                  <<04784>>19815000
      return;                                                  <<04784>>19820000
      end;                                                     <<04784>>19825000
   if hour < 24 then                                           <<04784>>19830000
      begin   << build phony hour number >>                    <<04784>>19835000
      move fn(4) := "2400";                                    <<04784>>19840000
      return;                                                  <<04784>>19845000
      end;                                                     <<04784>>19850000
   if hour < 99 then                                           <<04784>>19855000
      begin  << bump phony hour number  >>                     <<04784>>19860000
      hour := hour +1;                                         <<04784>>19865000
      ascii(hour,10,fn(4));                                    <<04784>>19870000
      return;                                                  <<04784>>19875000
      end;                                                     <<04784>>19880000
   if day < 366 then                                           <<04784>>19885000
      begin   << build phony day number >>                     <<04784>>19890000
      move fn(1) :="3670000";                                  <<04784>>19895000
      return;                                                  <<04784>>19900000
      end;                                                     <<04784>>19905000
   if day < 999 then                                           <<04784>>19910000
      begin  << bump phony day number  >>                      <<04784>>19915000
      day := day + 1;                                          <<04784>>19920000
      ascii(day,10,fn(1));                                     <<04784>>19925000
      return;                                                  <<04784>>19930000
      end;                                                     <<04784>>19935000
   move fn(1) := "0000000";   << last resort >>                <<04784>>19940000
end;    << makefn >>                                           <<04784>>19945000
procedure cxsave executorhead;                                          19950000
   option privileged, uncallable;                                       19955000
begin                                                          <<u.rao>>19960000
double dl := [8/",",8/";",8/%15,8/0]d;  <<delimiters>>         <<u.rao>>19965000
equate                                                         <<u.rao>>19970000
   semi = 1;                                                   << i.a >>19975000
logical dummy = dl,                                            <<04784>>19980000
        triedonce := false;                                    <<04784>>19985000
integer numparms,                                              <<04784>>19990000
        fnum,                                                  <<04784>>19995000
        errorcode;                                             <<04784>>20000000
double array parms(0:2) = q;                                   <<u.rao>>20005000
byte pointer oldfname = parms;                                 <<u.rao>>20010000
byte oldfnamelen=parms+1;                                      <<u.rao>>20015000
logical filenamedata = parms+1;                                <<u.rao>>20020000
define delimiter = filenamedata.(11:5)#;                       <<u.rao>>20025000
byte pointer newfname = parms+2;                               <<u.rao>>20030000
byte pointer errparm = parms+4;                                <<u.rao>>20035000
byte array tempfname(0:35);                                    <<u.rao>>20040000
byte array stempfname(0:8);                                    <<04784>>20045000
byte pointer sptr;                                             <<04784>>20050000
logical lerrptr = errparm;                                     <<u.rao>>20055000
subroutine renamestemp;                                        <<04784>>20060000
begin                                                          <<04784>>20065000
<< this procedure is used when the cxsave proc. gotten a >>    <<04784>>20070000
<< temporary "S" file name to rename $oldpass to.  it    >>    <<04784>>20075000
<< now needs to close that "S" file permanent and rename >>    <<04784>>20080000
<< it to the file name desired by the user.              >>    <<04784>>20085000
                                                               <<04784>>20090000
<< close the temp. "S" file somehow, preferably permanent>>    <<04784>>20095000
   fclose(fnum,1,0);    << close as permanent >>               <<04784>>20100000
   if <> then    << close failed >>                            <<04784>>20105000
   begin                                                       <<04784>>20110000
      fclose(fnum,0,0);  << close with same disposition>>      <<04784>>20115000
      if <> then                                               <<04784>>20120000
         fclose(fnum,-1,0);    << must close >>                <<04784>>20125000
      ferror'(fnum,parmnum);                                   <<04784>>20130000
      qualifyfilename(sptr,tempfname);                         <<04784>>20135000
      cierr(errnum:=savetempclose,,0,@tempfname);              <<04784>>20140000
      return;                                                  <<04784>>20145000
   end;                                                        <<04784>>20150000
   fnum := fopen(sptr,1,%104); << open "S" file >>             <<04784>>20155000
   if <> then                                                  <<04784>>20160000
      begin                                                    <<04784>>20165000
      qualifyfilename(sptr,tempfname);                         <<04784>>20170000
      cierr(errnum:=savetempclose,,0,@tempfname);              <<04784>>20175000
      return;                                                  <<04784>>20180000
      end;                                                     <<04784>>20185000
   frename(fnum,newfname);  <<rename to users name>>           <<04784>>20190000
   if <> then                                                  <<04784>>20195000
      begin                                                    <<04784>>20200000
      ferror'(fnum,parmnum);                                   <<04784>>20205000
      qualifyfilename(sptr,tempfname);                         <<04784>>20210000
      fclose(fnum,-1,0);     <<must close>>                    <<04784>>20215000
      cierr(errnum := savetempfail,,0,@tempfname);             <<04784>>20220000
      return;                                                  <<04784>>20225000
      end;                                                     <<04784>>20230000
   fclose(fnum,1,0);    << close newfname >>                   <<04784>>20235000
   if <> then                                                  <<04784>>20240000
      fclose(fnum,-1,0);    << must close >>                   <<04784>>20245000
                                                               <<04784>>20250000
end;      << renamestemp >>                                    <<04784>>20255000
                                                               <<04784>>20260000
logical subroutine fcheckerr;                                  <<04784>>20265000
begin                                                          <<04784>>20270000
<< used to check the file error code returned by intrinsic >>  <<04784>>20275000
<< frename.  if error prints error msg and returns.        >>  <<04784>>20280000
fcheckerr := false;                                            <<04784>>20285000
fcheck(fnum,errorcode);                                        <<04784>>20290000
if errorcode <> 101 then                                       <<04784>>20295000
   begin                                                       <<04784>>20300000
   ferror'(fnum,parmnum);                                      <<04784>>20305000
   cierr(errnum := renamefailed);                              <<04784>>20310000
   fcheckerr := true;                                          <<04784>>20315000
   end;                                                                 20320000
end;        << fcheckerr  >>                                   <<04784>>20325000
                                                               <<u.rao>>20330000
              <<******************************>>               <<04784>>20335000
              <<                              >>               <<04784>>20340000
              <<    m a i n   c o d e         >>               <<04784>>20345000
              <<                              >>               <<04784>>20350000
              <<******************************>>               <<04784>>20355000
mycommand(parmsp,dl,3,numparms,parms);                         <<u.rao>>20360000
if numparms > 2 then                                           <<u.rao>>20365000
   begin                                                       <<u.rao>>20370000
   parmnum := 3;                                               <<u.rao>>20375000
   cierr(errnum := save2mp, errparm);                          <<u.rao>>20380000
   end                                                         <<u.rao>>20385000
else if numparms = 0 then                                      <<u.rao>>20390000
   begin                                                       <<u.rao>>20395000
   parmnum := 1;                                               <<u.rao>>20400000
   cierr(errnum := savereqfname,parmsp(1));                    <<u.rao>>20405000
   end                                                         <<u.rao>>20410000
else                                                           <<u.rao>>20415000
   begin                                                       <<u.rao>>20420000
   if delimiter=semi then  <<expected comma, found ";", warn>> <<u.rao>>20425000
      cierr(errnum := -savesemicolon, oldfname(oldfnamelen));  <<04785>>20430000
   <<have at least a legal number of parms. now validate them>><<u.rao>>20435000
   tos := checkfilename'(parms&lsr(8),dummy,dummy,lerrptr);    <<u.rao>>20440000
   if < then  <<file name error of some sort>>                 <<u.rao>>20445000
      begin                                                    <<u.rao>>20450000
      parmnum := 1;                                            <<u.rao>>20455000
      errnum := s0;                                            <<u.rao>>20460000
      cierr(*,errparm);                                        <<u.rao>>20465000
      end                                                      <<u.rao>>20470000
   else if > and s0 <> 0 then                                  <<u.rao>>20475000
      begin <<system defined file - $oldpass?>>                <<u.rao>>20480000
      if tos <> 3 then  <<not $oldpass>>                       <<u.rao>>20485000
         begin                                                 <<u.rao>>20490000
         parmnum := 1;                                         <<u.rao>>20495000
         cierr(errnum := saveexpectoldpass,oldfname);          <<u.rao>>20500000
         end                                                   <<u.rao>>20505000
      else if numparms <> 2 then  <<missing new file name>>    <<u.rao>>20510000
         begin                                                 <<u.rao>>20515000
         parmnum := 2;                                         <<u.rao>>20520000
         cierr(errnum := savereqfname, oldfname(oldfnamelen)); <<u.rao>>20525000
         end                                                   <<u.rao>>20530000
      else                                                     <<u.rao>>20535000
         begin  <<have $oldpass, check new file name>>         <<u.rao>>20540000
         tos := checkfilename'(parms(1)&lsr(8),dummy,dummy,lerrptr);    20545000
         if < then   <<file name error>>                       <<u.rao>>20550000
            begin                                              <<u.rao>>20555000
            parmnum := 2;                                      <<u.rao>>20560000
            errnum := s0;                                      <<u.rao>>20565000
            cierr(*,errparm);                                  <<u.rao>>20570000
            end                                                <<u.rao>>20575000
         else if > and tos <> 0 then                           <<u.rao>>20580000
            begin  <<sys defined file>>                        <<u.rao>>20585000
            parmnum := 2;                                      <<u.rao>>20590000
            cierr(errnum := savereqfname,newfname);            <<u.rao>>20595000
            end                                                <<u.rao>>20600000
         else  <<ok - let's do it>>                            <<u.rao>>20605000
            begin                                              <<u.rao>>20610000
            fnum:= fopen(,%2032,%10500);                       <<04784>>20615000
            if <>    then  <<open failed>>                     <<04784>>20620000
               begin                                           <<u.rao>>20625000
               ferror'(fnum,parmnum);                          <<04784>>20630000
               qualifyfilename(newfname,tempfname);            <<u.rao>>20635000
               cierr(errnum := saveopenoldpass,,0,@tempfname); <<u.rao>>20640000
               end                                             <<u.rao>>20645000
            else  <<open worked, now try rename>               <<rv.pv>>20650000
               begin                                           <<u.rao>>20655000
                   frename (fnum,newfname);                    <<04784>>20660000
                   if <>    then                               <<04784>>20665000
                      begin   <<rename failed >>               <<04784>>20670000
                      if fcheckerr then       <<get file err>> <<04784>>20675000
                      return                                   <<04784>>20680000
                      else                                     <<04784>>20685000
                        begin  << get temp "S" name >>         <<04784>>20690000
                        @sptr := @stempfname;                  <<04784>>20695000
tryagain:               if triedonce then makefn'(sptr) else   <<04784>>20700000
                                makefn(sptr);                  <<04784>>20705000
                        frename(fnum,sptr);                    <<04784>>20710000
                        if <> and stempfname <> "S0000000"     <<04784>>20715000
                           then                                <<04784>>20720000
                           if fcheckerr then                   <<04784>>20725000
                               return                          <<04784>>20730000
                               else                            <<04784>>20735000
                                  begin                        <<04784>>20740000
                                  triedonce := true;           <<04784>>20745000
                                  goto tryagain;               <<04784>>20750000
                                  end                          <<04784>>20755000
                        else renamestemp   <<"S" name to newfna<<04784>>20760000
                        end     << get temp "S" name >>        <<04784>>20765000
                      end     << rename failed >>              <<04784>>20770000
                   else                                        <<rv.pv>>20775000
                   begin <<rename worked, close with save>>    <<rv.pv>>20780000
                       fclose(fnum,1,0);                       <<04784>>20785000
                       if <>    then   <<close failed >>       <<04784>>20790000
                       begin                                   <<rv.pv>>20795000
                          ferror'(fnum,parmnum);               <<04784>>20800000
                          qualifyfilename(newfname,tempfname); <<rv.pv>>20805000
                          cierr(errnum:=saveclosoldpass,,0,    <<rv.pv>>20810000
                                @tempfname);                   <<rv.pv>>20815000
                       end                                     <<rv.pv>>20820000
                   end;                                        <<rv.pv>>20825000
               end                                             <<u.rao>>20830000
            end                                                <<u.rao>>20835000
         end                                                   <<u.rao>>20840000
      end                                                      <<u.rao>>20845000
   else  if numparms=1 then  <<regular file name>>             <<u.rao>>20850000
      begin                                                    <<u.rao>>20855000
      fnum:= fopen(oldfname,%2002,%10500);                     <<04784>>20860000
      if <>    then  <<open failed>>                           <<04784>>20865000
         begin                                                 <<u.rao>>20870000
         ferror'(fnum,parmnum);                                <<04784>>20875000
         qualifyfilename(oldfname,tempfname);                  <<u.rao>>20880000
         cierr(errnum := savetempopen,,0,@tempfname);          <<u.rao>>20885000
         end                                                   <<u.rao>>20890000
      else                                                     <<u.rao>>20895000
         begin                                                 <<u.rao>>20900000
         fclose(fnum,1,0);                                     <<04784>>20905000
         if <>    then  <<close failed>>                       <<04784>>20910000
            begin                                              <<u.rao>>20915000
            ferror'(fnum,parmnum);                             <<04784>>20920000
            qualifyfilename(oldfname,tempfname);               <<u.rao>>20925000
            cierr(errnum := savetempclose,,0,@tempfname);      <<u.rao>>20930000
            end                                                <<u.rao>>20935000
         end                                                   <<u.rao>>20940000
      end                                                      <<u.rao>>20945000
   else  <<regular file name but 2 parameters>>                <<u.rao>>20950000
      cierr(errnum := save2mp,newfname);                       <<u.rao>>20955000
   end;                                                        <<u.rao>>20960000
end;  <<cxsave>>                                               <<u.rao>>20965000
integer procedure formaccess'(level,accstring,sec,numparms,errnum);     20970000
value level;                                                   <<u.rao>>20975000
integer level,  <<level of security - 0/1/2 = file/group/acct>><<u.rao>>20980000
        numparms, <<number of parameters encountered before return>>    20985000
        errnum;  <<the usual meaning>>                         <<u.rao>>20990000
byte array accstring;  <<pointer to the access list>>          <<u.rao>>20995000
double sec;  <<the security matrix to be returned>>            <<u.rao>>21000000
  <<return value is address of next non-blank after accstring>><<u.rao>>21005000
option uncallable,privileged;                                  <<u.rao>>21010000
                                                               <<u.rao>>21015000
  <<this procedure parses the security specification and returns the>>  21020000
  <<matrix appropriate to the <level> in <sec>.  >>            <<u.rao>>21025000
                                                               <<u.rao>>21030000
begin                                                          <<u.rao>>21035000
logical levelmask := 1;<<bit 15=>file, bit 14=>group, bit 13=>acct>>    21040000
byte pointer stringptr = formaccess';                          <<u.rao>>21045000
byte pointer permit;  <<used in analyzing validity of user list<<u.rao>>21050000
<<individual parameter characteristics variables>>             <<u.rao>>21055000
byte pointer parm;  <<pointer to current parameter>>           <<u.rao>>21060000
integer parmlen;    <<length of current parameter>>            <<u.rao>>21065000
byte delim;         <<next delimiter after parameter>>         <<u.rao>>21070000
<<variables for parse>>                                        <<u.rao>>21075000
byte array pbaccessors(0:1)=pb :=                              <<u.rao>>21080000
   6,3,"ANY",%7,                                               <<u.rao>>21085000
   5,2,"AC" ,%7,                                               <<u.rao>>21090000
   5,2,"AL" ,%3,                                               <<u.rao>>21095000
   5,2,"GU" ,%3,                                               <<u.rao>>21100000
   5,2,"GL" ,%3,                                               <<u.rao>>21105000
   5,2,"CR" ,%1,                                               <<u.rao>>21110000
   0;                                                          <<u.rao>>21115000
byte array accessors(0:31);                                    <<u.rao>>21120000
byte array pbaccessmodes(0:1)=pb :=                            <<u.rao>>21125000
   3,1,"R",                                                    <<u.rao>>21130000
   3,1,"A",                                                    <<u.rao>>21135000
   3,1,"W",                                                    <<u.rao>>21140000
   3,1,"L",                                                    <<u.rao>>21145000
   3,1,"X",                                                    <<u.rao>>21150000
   3,1,"S",                                                    <<u.rao>>21155000
   0;                                                          <<u.rao>>21160000
byte array accessmodes(0:24);                                  <<u.rao>>21165000
<<variables for processing matrix  (already set for file)>>    <<u.rao>>21170000
integer factor := 6;  <<bit width of mode field in matrix>>    <<u.rao>>21175000
integer base := 3;  <<number of waste bits in matrix+1>>       <<u.rao>>21180000
integer shiftcount;  <<used when user has duplicate access>>   <<u.rao>>21185000
                                                               <<u.rao>>21190000
<<                 *********************                   >>  <<u.rao>>21195000
<<                 *   printwarning    *                   >>  <<u.rao>>21200000
<<                 *********************                   >>  <<u.rao>>21205000
                                                               <<u.rao>>21210000
subroutine printwarning;  <<prints duplicate access warning>>  <<u.rao>>21215000
begin                                                          <<u.rao>>21220000
case *(shiftcount/factor) of                                   <<u.rao>>21225000
   begin                                                       <<u.rao>>21230000
   cierr(errnum := -accessrredund, parm);  <<read>>            <<04785>>21235000
   cierr(errnum := -accessaredund, parm);  <<append>>          <<04785>>21240000
   cierr(errnum := -accesswredund, parm);  <<write>>           <<04785>>21245000
   cierr(errnum := -accesslredund, parm);  <<lock>>            <<04785>>21250000
   cierr(errnum := -accessxredund, parm);  <<execute>>         <<04785>>21255000
   cierr(errnum := -accesssredund, parm);  <<save>>            <<04785>>21260000
   end;                                                        <<u.rao>>21265000
end;  <<subroutine printwarning>>                              <<u.rao>>21270000
                                                               <<u.rao>>21275000
<<                 *********************                   >>  <<u.rao>>21280000
<<                 *  checkdupaccess   *                   >>  <<u.rao>>21285000
<<                 *********************                   >>  <<u.rao>>21290000
                                                               <<u.rao>>21295000
subroutine checkdupaccess(accessmask);                         <<u.rao>>21300000
value accessmask;                                              <<u.rao>>21305000
double accessmask;                                             <<u.rao>>21310000
begin                                                          <<u.rao>>21315000
<<this subroutine checks for the possiblity of the user>>      <<u.rao>>21320000
<<having specified an access:user point redundantly.  if>>     <<u.rao>>21325000
<<so the routine warns the user, but allows it.>>              <<u.rao>>21330000
<<the essence of the problem is that we are passed a bit>>     <<u.rao>>21335000
<<mask (accessmask) indicating the points we just parsed.>>    <<u.rao>>21340000
<<this requires us to carefully unpack the info from the >>    <<u.rao>>21345000
<<mask.  the difficulty arises from the fact that the mask>>   <<u.rao>>21350000
<<is different based on whether it is for file, acct or group>><<u.rao>>21355000
<<the algorithm is 1) find out whether any bits were >>        <<u.rao>>21360000
<<redundant, then 2) scan through those redundant bits,>>      <<u.rao>>21365000
<<identifying them as to their meaning.  fortunately this>>    <<u.rao>>21370000
<<check is done on a per user mode basis, allowing us to>>     <<u.rao>>21375000
<<put out a reasonable message.>>                              <<u.rao>>21380000
tos := accessmask;                                             <<u.rao>>21385000
tos := sec;    <<first and doubles together for redundant bits><<u.rao>>21390000
assemble(                                                      <<u.rao>>21395000
   cab,  <<two least significant words on tos>>                <<u.rao>>21400000
   and;  <<merge                             >>                <<u.rao>>21405000
   cab,  <<now do two most significant words>>                 <<u.rao>>21410000
   cab;                                                        <<u.rao>>21415000
   and);  <<merge, leaving msw on tos>>                        <<u.rao>>21420000
if ds1<>0d then                                                <<u.rao>>21425000
   begin   <<something was redundant, find it>>                <<u.rao>>21430000
   shiftcount := -base;  <<accounts for unused bits>>          <<u.rao>>21435000
   while s0<>0 do                                              <<u.rao>>21440000
      begin                                                    <<u.rao>>21445000
      shiftcount := shiftcount+1;  <<for scan idiosincracies>> <<u.rao>>21450000
      assemble(scan);                                          <<u.rao>>21455000
      shiftcount := shiftcount+xreg;                           <<u.rao>>21460000
      printwarning;                                            <<u.rao>>21465000
      end;                                                     <<u.rao>>21470000
   del;  <<pop exhausted word>>                                <<u.rao>>21475000
   shiftcount := 16-base;  <<reinitialize for second word>>    <<u.rao>>21480000
   while s0<>0 do                                              <<u.rao>>21485000
      begin                                                    <<u.rao>>21490000
      shiftcount := shiftcount+1;  <<ditto for scan instr>>    <<u.rao>>21495000
      assemble(scan);                                          <<u.rao>>21500000
      shiftcount := shiftcount+xreg;                           <<u.rao>>21505000
      printwarning;                                            <<u.rao>>21510000
      end;                                                     <<u.rao>>21515000
   del;                                                        <<u.rao>>21520000
   end                                                         <<u.rao>>21525000
else ddel;                                                     <<u.rao>>21530000
end;                                                           <<u.rao>>21535000
                                                               <<u.rao>>21540000
<<                 *********************                   >>  <<u.rao>>21545000
<<                 *       next        *                   >>  <<u.rao>>21550000
<<                 *********************                   >>  <<u.rao>>21555000
                                                               <<u.rao>>21560000
subroutine next;                                               <<u.rao>>21565000
   <<finds the next parameter, calculates its length,>>        <<u.rao>>21570000
   <<sets appropriate variables, finds next delimiter>>        <<u.rao>>21575000
begin                                                          <<u.rao>>21580000
numparms := numparms+1;                                        <<u.rao>>21585000
scan stringptr while %6440,1;                                  <<u.rao>>21590000
assemble(dup,ddup);                                            <<u.rao>>21595000
@parm := tos;                                                  <<u.rao>>21600000
move * := * while as,0;                                        <<u.rao>>21605000
assemble(cab,sub);  <<calculate length>>                       <<u.rao>>21610000
parmlen := tos;                                                <<u.rao>>21615000
scan * while %6440,1;  <<find next delim>>                     <<u.rao>>21620000
delim := bps0;                                                 <<u.rao>>21625000
@stringptr := tos+1;                                           <<u.rao>>21630000
end;                                                           <<u.rao>>21635000
                                                               <<u.rao>>21640000
<<                 *********************                   >>  <<u.rao>>21645000
<<                 *     main body     *                   >>  <<u.rao>>21650000
<<                 *********************                   >>  <<u.rao>>21655000
                                                               <<u.rao>>21660000
<<file security matrix format>>                                <<u.rao>>21665000
<<----------------------------------------------------------------->>   21670000
<<!   !   ! r ! r ! r ! r ! r ! r ! a ! a ! a ! a ! a ! a ! w ! w !>>   21675000
<<!   !   !any! ac! al! gu! gl! cr!any! ac! al! gu! gl! cr!any! ac!>>   21680000
<<----------------------------------------------------------------->>   21685000
<<! w ! w ! w ! w ! l ! l ! l ! l ! l ! l ! x ! x ! x ! x ! x ! x !>>   21690000
<<! al! gu! gl! cr!any! ac! al! gu! gl!(cr!any! ac! al! gu! gl! cr!>>   21695000
<<----------------------------------------------------------------->>   21700000
                                                               <<u.rao>>21705000
<<file security variables set on entry>>                       <<u.rao>>21710000
if level = 1 then  <<group>>                                   <<u.rao>>21715000
   begin                                                       <<u.rao>>21720000
<<group security matrix format>>                               <<u.rao>>21725000
<<----------------------------------------------------------------->>   21730000
<<!   !   ! r ! r ! r ! r ! r ! a ! a ! a ! a ! a ! w ! w ! w ! w !>>   21735000
<<!   !   !any! ac! al! gu! gl!any! ac! al! gu! gl!any! ac! al! gu!>>   21740000
<<----------------------------------------------------------------->>   21745000
<<! w ! l ! l ! l ! l ! l ! x ! x ! x ! x ! x ! s ! s ! s ! s ! s !>>   21750000
<<! gl!any! ac! al! gu! gl!any! ac! al! gu! gl!any! ac! al! gu! gl!>>   21755000
<<----------------------------------------------------------------->>   21760000
   factor := 5;                                                <<u.rao>>21765000
   levelmask := 2;                                             <<u.rao>>21770000
   end                                                         <<u.rao>>21775000
else  if > then  <<account security matrix>>                   <<u.rao>>21780000
   begin                                                       <<u.rao>>21785000
<<account security matrix>>                                    <<u.rao>>21790000
<<----------------------------------------------------------------->>   21795000
<<!   !   !   !   ! r ! r ! a ! a ! w ! w ! l ! l ! x ! x ! s ! s !>>   21800000
<<!   !   !   !   !any! ac!any! ac!any! ac!any! ac!any! ac!any! ac!>>   21805000
<<----------------------------------------------------------------->>   21810000
   base := 5;                                                  <<u.rao>>21815000
   factor := 2;                                                <<u.rao>>21820000
   levelmask := 4;                                             <<u.rao>>21825000
   end;                                                        <<u.rao>>21830000
numparms := 0;                                                 <<u.rao>>21835000
<<all variables have been initialized (except sec)>>           <<u.rao>>21840000
<<now we start the actual processing. the scheme is   >>       <<u.rao>>21845000
<<  check for "("                                     >>       <<u.rao>>21850000
<<  while more access lists do                        >>       <<u.rao>>21855000
<<     process specified access modes into access mask>>       <<u.rao>>21860000
<<     check for ":"                                  >>       <<u.rao>>21865000
<<     for each specified accessor, lor the access    >>       <<u.rao>>21870000
<<        mask into the security matrix               >>       <<u.rao>>21875000
<<     end                                            >>       <<u.rao>>21880000
<<  check for ")"                                     >>       <<u.rao>>21885000
                                                               <<u.rao>>21890000
scan accstring while %6440,1;  <<strip blanks>>                <<u.rao>>21895000
if bps0 <> "(" then                                            <<u.rao>>21900000
   cierr(errnum := accessexpectlparen, bps0)                   <<u.rao>>21905000
else  <<have leading "(">>                                     <<u.rao>>21910000
   begin                                                       <<u.rao>>21915000
   tos := tos+1;                                               <<u.rao>>21920000
   scan * while %6440,1;  <<scan for next non-blank>>          <<u.rao>>21925000
   @stringptr := tos;  <<initialize stringptr>>                <<u.rao>>21930000
   if stringptr = ")" then  <<null access string>>             <<u.rao>>21935000
      begin                                                    <<u.rao>>21940000
      scan stringptr(1) while %6440,1;                         <<u.rao>>21945000
      @stringptr := tos;                                       <<u.rao>>21950000
      numparms := 1;                                           <<u.rao>>21955000
      return                                                   <<u.rao>>21960000
      end;                                                     <<u.rao>>21965000
   <<now initialize security mask>>                            <<u.rao>>21970000
   if level=2 then sec := [16/1,16/0]d <<account, force s:ac>> <<u.rao>>21975000
              else sec := 0d;                                  <<u.rao>>21980000
   <<ok, we have the preliminaries done with.  the task>>      <<u.rao>>21985000
   <<now is to parse the body of the access list>>             <<u.rao>>21990000
   move accessmodes := pbaccessmodes,(25);                     <<u.rao>>21995000
   move accessors := pbaccessors,(32);                         <<u.rao>>22000000
   do begin  <<until no more access lists>>                    <<u.rao>>22005000
      <<first task is to create access mask template>>         <<u.rao>>22010000
      tos := 0d;   <<initialize template>>                     <<u.rao>>22015000
      do begin  <<until end of modelist>>                      <<u.rao>>22020000
         <<strategy is to loop through mode list, creating>>   <<u.rao>>22025000
         <<a double with bits set for "ANY" with  the >>       <<u.rao>>22030000
         <<specified modes and the specified bit spacing>>     <<u.rao>>22035000
         next;  <<set characteristics of next parm>>           <<u.rao>>22040000
         tos := search(parm,parmlen,accessmodes) - 1;          <<u.rao>>22045000
         if < then <<unknown access mode>>                     <<u.rao>>22050000
            begin                                              <<u.rao>>22055000
            if level < 1 then errnum:=accessunknownfmode       <<u.rao>>22060000
            else if = then    errnum:=accessunknowngmode       <<u.rao>>22065000
            else              errnum:=accessunknownamode;      <<u.rao>>22070000
            cierr(errnum,parm);                                <<u.rao>>22075000
            return;                                            <<u.rao>>22080000
            end;                                               <<u.rao>>22085000
         if (s0=5) and (level<>1) then                         <<u.rao>>22090000
            begin <<warn - illegal use of save mode>>          <<u.rao>>22095000
            del;                                               <<u.rao>>22100000
            if level = 0 then errnum := -accessfsnotpermit     <<04785>>22105000
                         else errnum := -accessasnotpermit;    <<04785>>22110000
            cierr(errnum,parm);                               <<<04785>>22115000
            end                                                <<u.rao>>22120000
         else                                                  <<u.rao>>22125000
            begin <<everything good, set mask bit>>            <<u.rao>>22130000
            x := tos*factor+base;  <<offset from bit 31>>      <<u.rao>>22135000
            assemble(dcsl 0,x;  <<rotate to bit 31>>           <<u.rao>>22140000
                     tsbc 15);  <<set access bit>>             <<u.rao>>22145000
            <<note:  x has the shift count in it, upon which>> <<u.rao>>22150000
            <<the following assemble depends.  don't mess it up<<u.rao>>22155000
            if <> then  <<access mode redundantly specified>>  <<u.rao>>22160000
               cierr(errnum := -accessredundmode, parm);       <<04785>>22165000
            assemble(dcsr 0,x);  <<rotate back>>               <<u.rao>>22170000
            end                                                <<u.rao>>22175000
         end until delim <> ",";                               <<u.rao>>22180000
      <<access mode list parsed. now check for ":">>           <<u.rao>>22185000
      if delim <> ":" then                                     <<u.rao>>22190000
         begin                                                 <<u.rao>>22195000
         cierr(errnum := accessexpectcolon, stringptr(-1));    <<u.rao>>22200000
         return                                                <<u.rao>>22205000
         end;                                                  <<u.rao>>22210000
      <<now process user list.  as we find a valid user, >>    <<u.rao>>22215000
      <<we shift the prototype mode list (double on tos) >>    <<u.rao>>22220000
      <<and lor it into the new security matrix>>              <<u.rao>>22225000
      do begin  <<until end of user list>>                     <<u.rao>>22230000
         next;                                                 <<u.rao>>22235000
         x := search(parm,parmlen,accessors,permit)-1;         <<u.rao>>22240000
         if < then <<unknown accessor type>>                   <<u.rao>>22245000
            begin                                              <<u.rao>>22250000
            if level < 1 then errnum := accessunknownfuser     <<u.rao>>22255000
            else if = then errnum := accessunknownguser        <<u.rao>>22260000
            else errnum := accessunknownauser;                 <<u.rao>>22265000
            cierr(errnum,parm);                                <<u.rao>>22270000
            return                                             <<u.rao>>22275000
            end;                                               <<u.rao>>22280000
         if (logical(permit) land levelmask) = 0 then          <<u.rao>>22285000
            begin  <<warn - not permitted for this level>>     <<u.rao>>22290000
            del;                                               <<u.rao>>22295000
            if level=1 then errnum := -accesscrnotpermit       <<04785>>22300000
                        else errnum := -accessusnotpermit;     <<04785>>22305000
            cierr(errnum,parm);                                <<04785>>22310000
            end                                                <<u.rao>>22315000
         else                                                  <<u.rao>>22320000
            begin                                              <<u.rao>>22325000
            <<have valid user type and a valid access mode>>   <<u.rao>>22330000
            <<mask.  now process the mask into the security>>  <<u.rao>>22335000
            <<matrix.  the index register has the ordinal of>> <<u.rao>>22340000
            <<the user type and the prototype mode mask is >>  <<u.rao>>22345000
            <<in s-0 and s-1>>                                 <<u.rao>>22350000
            assemble(ddup;  <<copy mode mask>>                 <<u.rao>>22355000
                     dcsr 0,x); <<shift copy by user type>>    <<u.rao>>22360000
            checkdupaccess(ds1);                               <<u.rao>>22365000
            tos := sec;                                        <<u.rao>>22370000
            assemble(cab, <<get 2 least significant words>>    <<u.rao>>22375000
                     or;  <<merge them>>                       <<u.rao>>22380000
                     cab, <<get 2 most significant words>>     <<u.rao>>22385000
                     cab;                                      <<u.rao>>22390000
                     or,  <<merge them>>                       <<u.rao>>22395000
                     xch); <<put back in order>>               <<u.rao>>22400000
            sec := tos;  <<new bits lor'd into old mask>>      <<u.rao>>22405000
            end;                                               <<u.rao>>22410000
         end until delim <> ",";                               <<u.rao>>22415000
      ddel;  <<pop prototype mode mask>>                       <<u.rao>>22420000
      end until delim <> ";";  <<global do loop>>              <<u.rao>>22425000
                                                               <<u.rao>>22430000
   <<we have now processed the entire set of access lists>>    <<u.rao>>22435000
   <<time to fold our tents and steal away into the night>>    <<u.rao>>22440000
   if delim <> ")" then                                        <<u.rao>>22445000
      cierr(errnum := accessexpectrparen, stringptr(-1))       <<u.rao>>22450000
   else                                                        <<u.rao>>22455000
      begin  <<find next non-blank beyond ")">>                <<u.rao>>22460000
      scan stringptr while %6440,1;                            <<u.rao>>22465000
      @stringptr := tos;                                       <<u.rao>>22470000
      end;                                                     <<u.rao>>22475000
   end;                                                        <<u.rao>>22480000
end;  <<formaccess'>>                                          <<u.rao>>22485000
integer procedure getflabel (fileref, len, flabel, fldn, faddr,         22490000
      fnum,sirinfo);                                           <<04.ro>>22495000
   value len;                                                           22500000
   byte array fileref;                 <<u-supplied fileref>>           22505000
   integer len;                        <<its length>>                   22510000
   array flabel;                       <<128 wd target array>>          22515000
   integer fldn;                       <<file's ldn>>                   22520000
   double faddr;                       <<file's sector addr>>           22525000
   integer fnum;  <<fnum of file for which we want file label>><<04.ro>>22530000
   double sirinfo;                     <<sir and flags to release>>     22535000
   option variable, privileged, uncallable;                             22540000
<< analyzes the filereference;  gets the file label;  verifies lockword;22545000
   and ensures that caller is creator.                                  22550000
   filesir locked on return for update.                                 22555000
                                                                        22560000
   alternate call:                                                      22565000
integer procedure getflabel (fileref, len, flabel);                     22570000
   same as above but filesir released.  for examination.                22575000
                                                                        22580000
   returns error number if one was found.>>                    <<u.rao>>22585000
                                                                        22590000
begin                                                                   22595000
   array             qarray(*)         =q+0;                   <<06567>>22600000
   integer           pcbglobloc;                               <<06567>>22605000
   logical array jitarr(0:jit'entry'size-1);                   <<06840>>22610000
   integer jit'dstn;                                           <<06840>>22615000
   integer           returnval         = getflabel;                     22620000
   logical           pmask             = q-4;                           22625000
   byte pointer      bflabel           := @flabel;                      22630000
   define            flaname           = bflabel (16)  #;      << i.a >>22635000
   integer           type              := accountlevel;        <<38.pv>>22640000
   double            flabaddr          ;                       <<rv.pv>>22645000
   integer           ldev              ;                       <<rv.pv>>22650000
   byte pointer      gpntr,                                             22655000
                     errptr,  <<dummy for checkfilename'>>     <<u.rao>>22660000
                     apntr;                                             22665000
   logical           lgpntr            = gpntr,                         22670000
                     lerrptr           = errptr,               <<u.rao>>22675000
                     lapntr            = apntr;                         22680000
   integer array     uan(0:7),                                 <<06840>>22685000
                     fname (0:57),                                      22690000
                     gname (*)         = fname (4),                     22695000
                     aname (*)         = gname (4);                     22700000
   byte array        banun (*)         = uan,                           22705000
                     bfname (*)        = fname,                         22710000
                     bgname (*)        = gname,                         22715000
                     baname (*)        = aname,                         22720000
                     lock (*)          = aname (4);                     22725000
                                                                        22730000
   fname := "  ";                                                       22735000
   move fname (1) := fname, (31);                                       22740000
   tos := 0;  <<return space>>                                 <<u.rao>>22745000
   tos := @fileref;                                            <<u.rao>>22750000
   tos := len;                                                 <<u.rao>>22755000
   tos := checkfilename'(*,lgpntr,lapntr,lerrptr);             <<u.rao>>22760000
   if < then  <<file name parse error>>                        <<u.rao>>22765000
      begin                                                    <<u.rao>>22770000
      returnval := s0;                                         <<u.rao>>22775000
      cierr(*,errptr);                                         <<u.rao>>22780000
      return                                                   <<u.rao>>22785000
      end                                                      <<u.rao>>22790000
   else if > then  <<requires actual designator>>              <<u.rao>>22795000
      begin                                                    <<u.rao>>22800000
      cierr(returnval := reqformalfdesig);                     <<u.rao>>22805000
      return                                                   <<u.rao>>22810000
      end;                                                     <<u.rao>>22815000
   move bfname := fileref while ans, 0;                                 22820000
   if bps0 = "/" then                                                   22825000
      begin                                                             22830000
      tos := @lock;                                                     22835000
      assemble (xch, inca);                                             22840000
      move * := * while ans, 0;                                         22845000
      end;                                                              22850000
   if bps0 = "." then                                                   22855000
      begin                                                             22860000
      type := type -1;                                                  22865000
      move bgname := gpntr while ans, 0;                                22870000
      if bps0 = "." then                                                22875000
         begin                                                          22880000
         type := type -1;                                               22885000
         move baname := apntr while ans;                                22890000
         end else                                              <<31.pv>>22895000
          who (,,,,,baname);                                   <<31.pv>>22900000
      end else                                                 <<31.pv>>22905000
       who (,,,,bgname,baname);                                <<31.pv>>22910000
   <<at this point we have the file name.  next we open the>>  <<04.ro>>22915000
   <<file.  this has no relevance to the actual accessing of>> <<04.ro>>22920000
   <<the file.  it's only purpose is to cause a mount of the>> <<04.ro>>22925000
   <<private volume, if necessary>>                            <<04.ro>>22930000
   fnum := fopen(fileref,%2001,%10717);<<inonly,nobuf,no sec.>><<01652>>22935000
   if <> then                                                  <<04.ro>>22940000
      begin   <<open failed, tell user>>                       <<04.ro>>22945000
      ferror'(fnum, type);                                     <<04.ro>>22950000
      qualifyfilename(fileref, bfname);                        <<04.ro>>22955000
      cierr(returnval := getflabopen,,0,@bfname);              <<04.ro>>22960000
      return                                                   <<04.ro>>22965000
      end;                                                     <<04.ro>>22970000
   pxglobal;                                                   <<06567>>22975000
   jit'dstn:=pxg'jitdst;                                       <<06840>>22980000
   tos:=@jitarr;                                               <<06840>>22985000
   tos:=jit'dstn;                                              <<06840>>22990000
   tos:=0;                                                     <<06840>>22995000
   tos:=jit'entry'size;                                        <<06840>>23000000
   assemble(mfds 4);                                           <<06840>>23005000
   move uan(0):=jithacctname,(4);                              <<06840>>23010000
   move uan(4):=jitusername,(4);                               <<06840>>23015000
   tos := filesir;                                                      23020000
   tos := getsir (filesir);                                             23025000
   if pmask then sirinfo := ds1;                                        23030000
   fgetinfo (fnum,,,,,,ldev,,,,,,,,,,,,,flabaddr);             <<rv.pv>>23035000
   tos := 0;                                                            23040000
   tos := ldev;                                                <<rv.pv>>23045000
   tos := flabaddr;                                            <<rv.pv>>23050000
   tos := 0;                                                            23055000
   tos := @flabel;                                                      23060000
   if pmask then                                                        23065000
      begin                                                             23070000
      fldn := s4;                                                       23075000
      faddr := ds3;                                                     23080000
      end;                                                              23085000
   tos := flabio (*,*,*,*);                                             23090000
   if tos <> 0 then  <<disc io error>>                         <<u.rao>>23095000
      begin                                                    <<u.rao>>23100000
      tos := sirinfo;                                          <<06.ro>>23105000
      relsir(*,*);  <<release file sir>>                       <<06.ro>>23110000
      cierr(returnval := discioerr);                           <<u.rao>>23115000
      fclose(fnum,0,0);                                        <<06.ro>>23120000
      return;                                                  <<06.ro>>23125000
      end;                                                     <<u.rao>>23130000
   if flaname <> banun,(16) then  <<creator conflict>>         <<u.rao>>23135000
      begin                                                    <<u.rao>>23140000
      tos := sirinfo;                                          <<06.ro>>23145000
      relsir(*,*);   <<release file system sir>>               <<06.ro>>23150000
      cierr(returnval := notcreator);                          <<u.rao>>23155000
      fclose(fnum,0,0);                                        <<06.ro>>23160000
      return;                                                  <<06.ro>>23165000
      end;                                                     <<u.rao>>23170000
   if not (pmask) then                                                  23175000
      begin                                                    <<04.ro>>23180000
         tos := sirinfo;                                       <<06.ro>>23185000
         relsir(*,*);  <<release file sir>>                    <<06.ro>>23190000
         fclose(fnum,0,0);                                     <<04.ro>>23195000
      end;                                                     <<04.ro>>23200000
   end    <<getflabel>>;                                                23205000
logical procedure altsecurity(errnum,fileref,type,sec);        <<u.rao>>23210000
value fileref,type,sec;                                        <<u.rao>>23215000
double fileref,sec;                                            <<u.rao>>23220000
integer errnum,type;                                           <<u.rao>>23225000
option privileged, uncallable, variable;                       <<u.rao>>23230000
<<this procedure is called by cxrelease, cxsecure, cxaltsec>>  <<u.rao>>23235000
<<its function is to actually do the file label manipulations>><<u.rao>>23240000
<<fileref is a double with a byte pointer to the beginning of>><<u.rao>>23245000
<<the file reference in word 1 and the length of the file    >><<u.rao>>23250000
<<reference in word 2.  this is usually obtained by a lsr(8) >><<u.rao>>23255000
<<on the double returned from mycommand.                     >><<u.rao>>23260000
<<type = 1 => secure the file                                >><<u.rao>>23265000
<<     = 0 => release the file                               >><<u.rao>>23270000
<<     = -1 => alter the security mask.                      >><<u.rao>>23275000
<<sec is present iff type = -1 and is new security mask.     >><<u.rao>>23280000
begin                                                          <<u.rao>>23285000
double sirinfo; <<file system sir>>                            <<u.rao>>23290000
double faddr;                                                  <<u.rao>>23295000
integer fldn;  <<logical device number>>                       <<u.rao>>23300000
integer array flabel(0:127);                                   <<u.rao>>23305000
double array dflabel(*)=flabel;                                <<u.rao>>23310000
logical pmask = q-4;                                           <<u.rao>>23315000
byte pointer fref = fileref;                                   <<u.rao>>23320000
integer len = fileref+1;                                       <<u.rao>>23325000
integer fnum;  <<holds fnum of fileref opened in getflabel>>   <<04.ro>>23330000
                                                               <<u.rao>>23335000
altsecurity := false;                                          <<u.rao>>23340000
errnum := getflabel(fref,len,flabel,fldn,faddr,fnum,sirinfo);  <<u.rao>>23345000
if errnum = 0 then                                             <<u.rao>>23350000
   begin  <<ok - go on>>                                       <<u.rao>>23355000
   if pmask then <<altsec, since new security mask passed>>    <<u.rao>>23360000
      dflabel(flsecmatrix) := sec                              <<u.rao>>23365000
   else  <<release/secure>>                                    <<u.rao>>23370000
      flabel( file'secure ).(15:1) := type;                    << 8500>>23375000
   tos := flabio(fldn,faddr,1,flabel);                         <<u.rao>>23380000
   tos := sirinfo;                                             <<u.rao>>23385000
   relsir(*,*);  <<release file system sir gotten by getflabel><<u.rao>>23390000
   fclose(fnum,0,0);  <<close modified file>>                  <<04.ro>>23395000
   altsecurity := true;                                        <<u.rao>>23400000
   if tos <> 0 then                                            <<u.rao>>23405000
      begin                                                    <<u.rao>>23410000
      altsecurity := false;                                    <<u.rao>>23415000
      cierr(errnum := discioerr);                              <<u.rao>>23420000
      end;                                                     <<u.rao>>23425000
   flabel := 0;                                                <<u.rao>>23430000
   move flabel(1) := flabel,(127);                             <<u.rao>>23435000
   end;                                                        <<u.rao>>23440000
end;                                                           <<u.rao>>23445000
procedure cxrelease executorhead;                              <<u.rao>>23450000
option privileged, uncallable;                                 <<u.rao>>23455000
begin                                                          <<u.rao>>23460000
double array parms(0:1)=q;                                     <<u.rao>>23465000
byte pointer errptr = parms+2;                                 <<u.rao>>23470000
integer numparms;                                              <<u.rao>>23475000
double dl:=commasemicr;                                        <<u.rao>>23480000
mycommand(parmsp,dl,2,numparms,parms);                         <<u.rao>>23485000
parmnum := 1;                                                  <<u.rao>>23490000
if numparms >= 2 then                                          <<u.rao>>23495000
   cierr(errnum := release2mp, errptr)                         <<u.rao>>23500000
else if numparms < 1 then                                      <<u.rao>>23505000
   cierr(errnum := releasenotenuf, parmsp(1))                  <<u.rao>>23510000
else   <<everything parsed ok>>                                <<u.rao>>23515000
   if altsecurity(errnum,parms&lsr(8),0) then                  <<u.rao>>23520000
      parmnum := 0;  <<everything is fine>>                    <<u.rao>>23525000
end;                                                           <<u.rao>>23530000
procedure cxsecure executorhead;                               <<u.rao>>23535000
option privileged,uncallable;                                  <<u.rao>>23540000
begin                                                          <<u.rao>>23545000
double array parms(0:1)=q;                                     <<u.rao>>23550000
byte pointer errptr = parms+2;                                 <<u.rao>>23555000
integer numparms;                                              <<u.rao>>23560000
double dl := commasemicr;                                      <<u.rao>>23565000
mycommand(parmsp,dl,2,numparms,parms);                         <<u.rao>>23570000
parmnum := 1;                                                  <<u.rao>>23575000
if numparms >= 2 then                                          <<u.rao>>23580000
   cierr(errnum := secure2mp,errptr)                           <<u.rao>>23585000
else if numparms < 1 then                                      <<u.rao>>23590000
   cierr(errnum := securenotenuf, parmsp(1))                   <<u.rao>>23595000
else  <<everything parsed ok so far>>                          <<u.rao>>23600000
   if altsecurity(errnum, parms&lsr(8),1) then                 <<u.rao>>23605000
      parmnum := 0;                                            <<u.rao>>23610000
end;                                                           <<u.rao>>23615000
procedure cxaltsec executorhead;                               <<u.rao>>23620000
option privileged, uncallable;                                 <<u.rao>>23625000
begin                                                          <<u.rao>>23630000
double array parms(0:1) = q;                                   <<u.rao>>23635000
integer dl := semicr;                                          <<u.rao>>23640000
integer numparms;                                              <<u.rao>>23645000
double sec := [6/32,6/32,6/32,6/32,6/32]d;                     <<u.rao>>23650000
byte pointer accstring = parms+2;                              <<u.rao>>23655000
                                                               <<u.rao>>23660000
mycommand(parmsp,dl,2,numparms,parms);                         <<u.rao>>23665000
if numparms < 1 then                                           <<u.rao>>23670000
   begin                                                       <<u.rao>>23675000
   parmnum := 1;                                               <<u.rao>>23680000
   cierr(errnum := altsecnotenuf, parmsp(1));                  <<u.rao>>23685000
   end                                                         <<u.rao>>23690000
else                                                           <<u.rao>>23695000
   begin                                                       <<u.rao>>23700000
   if > then  <<modelist included?>>                           <<u.rao>>23705000
      begin                                                    <<u.rao>>23710000
      tos := formaccess'(0,accstring,sec,numparms,errnum);     <<u.rao>>23715000
      if errnum > 0 then   <<error reported>>                  <<u.rao>>23720000
         begin                                                 <<u.rao>>23725000
         parmnum := numparms;                                  <<u.rao>>23730000
         return                                                <<u.rao>>23735000
         end;                                                  <<u.rao>>23740000
      if bps0 <> %15 <<cr>> then                               <<u.rao>>23745000
         begin                                                 <<u.rao>>23750000
         parmnum := numparms+1;                                <<u.rao>>23755000
         cierr(errnum := altsec2mp, bps0);                     <<u.rao>>23760000
         return                                                <<u.rao>>23765000
         end;                                                  <<u.rao>>23770000
      end;                                                     <<u.rao>>23775000
   if not altsecurity(errnum,parms&lsr(8),-1,sec) then         <<u.rao>>23780000
      parmnum := 1;                                            <<u.rao>>23785000
   end;                                                        <<u.rao>>23790000
end;  <<cxaltsec>>                                             <<u.rao>>23795000
$page    "LISTF EXECUTOR AND RELATED PROCEDURES"                        23800000
$control   segment  =  cilistf                                          23805000
                                                                        23810000
procedure listfnotmtdmsg (ghvsname',sourcedst);                <<rv.pv>>23815000
    value sourcedst;  integer sourcedst;                       <<rv.pv>>23820000
    array ghvsname';                                           <<rv.pv>>23825000
    option privileged, uncallable;                             <<04.ro>>23830000
    begin                                                      <<rv.pv>>23835000
       integer errnum;                                         <<04785>>23840000
        array                                                  <<rv.pv>>23845000
            hvsname (0:(namesize*3)-1);                        <<rv.pv>>23850000
        byte array                                             <<rv.pv>>23855000
            string (0:((namesize*3)*2)+2);                     <<rv.pv>>23860000
        tos := @hvsname;                                       <<rv.pv>>23865000
        tos := sourcedst;                                      <<rv.pv>>23870000
        tos := @ghvsname';                                     <<rv.pv>>23875000
        tos := namesize*3;                                     <<rv.pv>>23880000
        assemble (mfds);                                       <<rv.pv>>23885000
        formname (1,string,hvsname (namesize*2),               <<rv.pv>>23890000
                  hvsname (namesize),hvsname,hvsname);         <<rv.pv>>23895000
        cierr (errnum := -listfhvsnotmtd,,0,@string);          <<04785>>23900000
    end;<<of listfnotmtdmsg>>                                  <<rv.pv>>23905000
                                                               <<04.km>>23910000
                                                               <<04.km>>23915000
$control  segment=cilistf                                      <<04.km>>23920000
<<********************************************************************>>23925000
<< m u l t i l i n e >>                                        <<04.km>>23930000
                                                               <<04.km>>23935000
integer procedure multiline(file,msg,msglen,field,fieldlen,    <<04.km>>23940000
                            lastcctl,prefix,prefixlen);        <<04.km>>23945000
  value file,msg,msglen,field,fieldlen,lastcctl,prefixlen;     <<04.km>>23950000
  integer file,msglen,field,fieldlen,lastcctl,prefixlen;       <<04.km>>23955000
  byte pointer msg;                                            <<04.km>>23960000
  byte array prefix;                                           <<04.km>>23965000
  option privileged,uncallable,variable;                       <<04.km>>23970000
begin                                                          <<04.km>>23975000
  comment:                                                     <<04.km>>23980000
    writes "MSG" to "FILE" at position "FIELD" within record.  <<04.km>>23985000
    if "MSGLEN" exceeds "FIELDLEN", the message is broken on   <<04.km>>23990000
    word boundary and written on multiple lines.  first line   <<04.km>>23995000
    may be prefaced by "PREFIX" -- subsequent lines contain    <<04.km>>24000000
    blanks to the left of "FIELD".  last line is written with  <<04.km>>24005000
    "CCTL" carriage control.                                   <<04.km>>24010000
                                                               <<04.km>>24015000
    returns same condition code as fcontrol or fwrite.  also   <<04.km>>24020000
    returns file system error number (fcheck).                 <<04.km>>24025000
                                                               <<04.km>>24030000
    input parameters:                                          <<04.km>>24035000
      msglen=    # bytes (positive)                            <<04.km>>24040000
      field=     0-origined byte position within record        <<04.km>>24045000
      fieldlen=  # bytes (positive)                            <<04.km>>24050000
      lastcctl=  "FWRITE" cctl                                 <<04.km>>24055000
      prefixlen= # bytes (positive).                           <<04.km>>24060000
                                                               <<04.km>>24065000
    default values are:                                        <<04.km>>24070000
      file=      $stdlist                                      <<04.km>>24075000
      msglen=    0                                             <<04.km>>24080000
      field=     0                                             <<04.km>>24085000
      fieldlen=  recsize-field                                 <<04.km>>24090000
      lastcctl=  0                                             <<04.km>>24095000
      prefixlen= 0.                                            <<04.km>>24100000
                                                               <<04.km>>24105000
    if "FIELD" exceeds recsize the default is taken.  however, <<04.km>>24110000
    field+fieldlen may exceed recsize.  if file<=0 or field<0  <<04.km>>24115000
    or fieldlen<=0, the corresponding default is taken.  if    <<04.km>>24120000
    "MSG" or "PREFIX" is not passed, the corresponding default <<04.km>>24125000
    "MSGLEN" or "PREFIXLEN" is taken.                          <<04.km>>24130000
    ;                                                          <<04.km>>24135000
                                                               <<04.km>>24140000
  integer mlinevalue= multiline;                               <<04.km>>24145000
  label exitinstr;                                             <<04.km>>24150000
  define exitproc= assemble(br *+1,i; con exitinstr) #;        <<04.km>>24155000
                                                               <<04.km>>24160000
  define fnflag= qparm.(8:1) #,        <<file passed>>         <<04.km>>24165000
         mflag=  qparm.(9:1) #,        <<msg passed>>          <<04.km>>24170000
         mlflag= qparm.(10:1) #,       <<msglen passed>>       <<04.km>>24175000
         fflag=  qparm.(11:1) #,       <<field passed>>        <<04.km>>24180000
         flflag= qparm.(12:1) #,       <<fieldlen passed>>     <<04.km>>24185000
         lflag=  qparm.(13:1) #,       <<lastcctl passed>>     <<04.km>>24190000
         pflag=  qparm.(14:1) #,       <<prefix passed>>       <<04.km>>24195000
         plflag= qparm #;              <<prefixlen passed>>    <<04.km>>24200000
  define qcc=     6:2 #;                                       <<04.km>>24205000
  equate ccl=     1,                                           <<04.km>>24210000
         cce=     2,                                           <<04.km>>24215000
         ccg=     0,                                           <<04.km>>24220000
         stdlist= 2;                                           <<04.km>>24225000
  byte topstack= multiline,                                    <<04.km>>24230000
       dummy=    topstack;                                     <<04.km>>24235000
  byte pointer temp;                                           <<04.km>>24240000
  integer qstatus= q-1,                                        <<04.km>>24245000
          x=       x,                                          <<04.km>>24250000
          s0=      s-0,                                        <<04.km>>24255000
          dl,                                                  <<04.km>>24260000
          last,                                                <<04.km>>24265000
          recsize,                                             <<04.km>>24270000
          cctl;                                                <<04.km>>24275000
  logical qparm= q-4;                                          <<04.km>>24280000
  pointer wtemp;                                               <<04.km>>24285000
  intrinsic fwrite,fgetinfo,fcheck;                            <<04.km>>24290000
                                                               <<04.km>>24295000
  array wbuf(*)=     q;                                        <<04.km>>24300000
  byte array buf(*)= wbuf;                                     <<04.km>>24305000
                                                               <<04.km>>24310000
                                                               <<04.km>>24315000
  <<*******************>>                                      <<04.km>>24320000
  << subroutine cxexit >>                                      <<04.km>>24325000
  <<*******************>>                                      <<04.km>>24330000
                                                               <<04.km>>24335000
  subroutine cxexit(ccode); value ccode; integer ccode;        <<04.km>>24340000
  begin                                                        <<04.km>>24345000
    qstatus.(qcc):=ccode;                                      <<04.km>>24350000
    if ccode=cce then multiline:=0                             <<04.km>>24355000
    else fcheck(file,mlinevalue);                              <<04.km>>24360000
    exitproc;                                                  <<04.km>>24365000
  end <<subroutine cxexit>>;                                   <<04.km>>24370000
                                                               <<04.km>>24375000
                                                               <<04.km>>24380000
  <<***************************>>                              <<04.km>>24385000
  << subroutine blankleftfield >>                              <<04.km>>24390000
  <<***************************>>                              <<04.km>>24395000
                                                               <<04.km>>24400000
  subroutine blankleftfield;                                   <<04.km>>24405000
  begin                                                        <<04.km>>24410000
    buf:=" ";                                                  <<04.km>>24415000
    move buf(1):=buf,(field);                                  <<04.km>>24420000
  end <<subroutine blankleftfield>>;                           <<04.km>>24425000
                                                               <<04.km>>24430000
                                                               <<04.km>>24435000
  <<*********************>>                                    <<04.km>>24440000
  << subroutine bytesize >>                                    <<04.km>>24445000
  <<*********************>>                                    <<04.km>>24450000
                                                               <<04.km>>24455000
  integer subroutine bytesize(length);                         <<04.km>>24460000
    value length; integer length;                              <<??,km>>24465000
  begin                                                        <<04.km>>24470000
    bytesize:=if length=-32768 or length>=16384 then 32767     <<04.km>>24475000
              else if length<0 then -length                    <<04.km>>24480000
              else 2*length;                                   <<04.km>>24485000
  end <<subroutine bytesize>>;                                 <<04.km>>24490000
                                                               <<04.km>>24495000
                                                               <<04.km>>24500000
  <<**************************>>                               <<04.km>>24505000
  << subroutine lastwordindex >>                               <<04.km>>24510000
  <<**************************>>                               <<04.km>>24515000
                                                               <<04.km>>24520000
  integer subroutine lastwordindex;                            <<04.km>>24525000
  begin                                                        <<04.km>>24530000
    comment:                                                   <<04.km>>24535000
      find word boundary.  we assume that msg(0) is nonblank   <<04.km>>24540000
      (ie., "MSG" has been left-deblanked);                    <<04.km>>24545000
                                                               <<04.km>>24550000
    x:=fieldlen;                                               <<04.km>>24555000
    while x>0 and msg(x)<>" " do x:=x-1;                       <<04.km>>24560000
    lastwordindex:=if x>0 then x else fieldlen;                <<04.km>>24565000
  end <<subroutine lastwordindex>>;                            <<04.km>>24570000
                                                               <<04.km>>24575000
                                                               <<04.km>>24580000
  <<***********************>>                                  <<04.km>>24585000
  << subroutine skipblanks >>                                  <<04.km>>24590000
  <<***********************>>                                  <<04.km>>24595000
                                                               <<04.km>>24600000
  subroutine skipblanks;                                       <<04.km>>24605000
  begin                                                        <<04.km>>24610000
    x:=0;                                                      <<04.km>>24615000
    while x<msglen and msg(x)=" " do x:=x+1;                   <<04.km>>24620000
    @msg:=@msg(x);                                             <<04.km>>24625000
    msglen:=msglen-x;                                          <<04.km>>24630000
  end <<subroutine skipblanks>>;                               <<04.km>>24635000
                                                               <<04.km>>24640000
                                                               <<04.km>>24645000
  <<*********************>>                                    <<04.km>>24650000
  << subroutine wordsize >>                                    <<04.km>>24655000
  <<*********************>>                                    <<04.km>>24660000
                                                               <<04.km>>24665000
  integer subroutine wordsize(bytelength);                     <<04.km>>24670000
    value bytelength; integer bytelength;                      <<04.km>>24675000
  begin                                                        <<04.km>>24680000
    wordsize:=(bytelength/2)+bytelength.(15:1);                <<04.km>>24685000
  end <<subroutine wordsize>>;                                 <<04.km>>24690000
                                                               <<04.km>>24695000
                                                               <<04.km>>24700000
  <<**********************>>                                   <<04.km>>24705000
  << subroutine writeline >>                                   <<04.km>>24710000
  <<**********************>>                                   <<04.km>>24715000
                                                               <<04.km>>24720000
  subroutine writeline;                                        <<04.km>>24725000
  begin                                                        <<04.km>>24730000
    comment:                                                   <<04.km>>24735000
      fill in "FIELD" with as much of "MSG" as possible.       <<04.km>>24740000
      we assume that "MSG" has been right-deblanked.  note     <<04.km>>24745000
      that area to the left of "FIELD" may or may not be       <<04.km>>24750000
      blank, to be set-up by caller;                           <<04.km>>24755000
                                                               <<04.km>>24760000
    skipblanks;                                                <<04.km>>24765000
    if msglen<=fieldlen then           <<assume fl>=1>>        <<04.km>>24770000
      begin                                                    <<04.km>>24775000
      last:=msglen;                    <<assume ml>0>>         <<04.km>>24780000
      cctl:=lastcctl;                                          <<04.km>>24785000
      end                                                      <<04.km>>24790000
    else                                                       <<04.km>>24795000
      begin                                                    <<04.km>>24800000
      last:=lastwordindex;                                     <<04.km>>24805000
      cctl:=0;                                                 <<04.km>>24810000
      end;                                                     <<04.km>>24815000
    move buf(field):=msg,(last);                               <<04.km>>24820000
    fwrite(file,wbuf,-(field+last),cctl);                      <<04.km>>24825000
    if <> then cxexit(if < then ccl else ccg);                 <<04.km>>24830000
    @msg:=@msg(last);                                          <<04.km>>24835000
    msglen:=msglen-last;                                       <<04.km>>24840000
  end <<subroutine writeline>>;                                <<04.km>>24845000
                                                               <<04.km>>24850000
                                                               <<04.km>>24855000
  <<************************>>                                 <<04.km>>24860000
  << subroutine writeprefix >>                                 <<04.km>>24865000
  <<************************>>                                 <<04.km>>24870000
                                                               <<04.km>>24875000
  subroutine writeprefix;                                      <<04.km>>24880000
  begin                                                        <<04.km>>24885000
    comment:                                                   <<04.km>>24890000
      write prefix on separate line;                           <<04.km>>24895000
                                                               <<04.km>>24900000
    tos:=wordsize(prefixlen);          <<allocate buffer>>     <<04.km>>24905000
    @temp:=(@wtemp:=@s0)&lsl(1);                               <<04.km>>24910000
    assemble(adds 0);                                          <<04.km>>24915000
    move temp:=prefix,(prefixlen);                             <<04.km>>24920000
    fwrite(file,wtemp,-prefixlen,0);                           <<04.km>>24925000
    if <> then cxexit(if < then ccl else ccg);                 <<04.km>>24930000
    tos:=wordsize(prefixlen);          <<deallocate buffer>>   <<04.km>>24935000
    assemble(subs 0);                                          <<04.km>>24940000
  end <<subroutine writeprefix>>;                              <<04.km>>24945000
                                                               <<04.km>>24950000
                                                               <<04.km>>24955000
  <<************************>>                                 <<04.km>>24960000
  << main procedure body    >>                                 <<04.km>>24965000
  <<                        >>                                 <<04.km>>24970000
  << check calling sequence >>                                 <<04.km>>24975000
  <<************************>>                                 <<04.km>>24980000
                                                               <<04.km>>24985000
  push(dl);                                                    <<04.km>>24990000
  dl:=tos;                                                     <<04.km>>24995000
  if not fnflag or file<=0 then file:=stdlist;                 <<04.km>>25000000
                                                               <<04.km>>25005000
  if not mflag or not mlflag or msglen<0 or                    <<04.km>>25010000
     @msg<dl or @msg(msglen)>@topstack then                    <<04.km>>25015000
    begin                                                      <<04.km>>25020000
    @msg:=@dummy;                                              <<04.km>>25025000
    msglen:=0;                                                 <<04.km>>25030000
    end;                                                       <<04.km>>25035000
  while msglen>0 and msg(msglen-1)=" " do msglen:=msglen-1;    <<04.km>>25040000
                                                               <<04.km>>25045000
  comment:                                                     <<04.km>>25050000
    check "FIELD" & "FIELDLEN".  device record size is         <<04.km>>25055000
    diminished by two (one for cctl) to avoid printing in last <<05.km>>25060000
    column, causing extra lf or home-up on some devices.       <<05.km>>25065000
    "FIELD" cannot equal "RECSIZE" to ensure that fieldlen>=1; <<05.km>>25070000
                                                               <<04.km>>25075000
  fgetinfo(file,<<fname>>,<<fops>>,<<aops>>,recsize);          <<04.km>>25080000
  if <> then cxexit(if < then ccl else ccg);                   <<04.km>>25085000
  recsize:=bytesize(recsize)-2;                                <<05.km>>25090000
  if not fflag or field<0 or field>=recsize then field:=0;     <<04.km>>25095000
  if not flflag or fieldlen=0 then fieldlen:=recsize-field;    <<04.km>>25100000
                                                               <<04.km>>25105000
  if not lflag then cctl:=0;                                   <<04.km>>25110000
                                                               <<04.km>>25115000
  if not pflag or not plflag or prefixlen<0 or                 <<04.km>>25120000
     @prefix<dl or @prefix(prefixlen)>@topstack then           <<04.km>>25125000
    begin                                                      <<04.km>>25130000
    @prefix:=@dummy;                                           <<04.km>>25135000
    prefixlen:=0;                                              <<04.km>>25140000
    end;                                                       <<04.km>>25145000
                                                               <<04.km>>25150000
  <<****************>>                                         <<04.km>>25155000
  << output message >>                                         <<04.km>>25160000
  <<****************>>                                         <<04.km>>25165000
                                                               <<04.km>>25170000
  tos:=wordsize(field+fieldlen);       <<allocate "WBUF">>     <<04.km>>25175000
  assemble(adds 0);                                            <<04.km>>25180000
                                                               <<04.km>>25185000
  if prefixlen>field then writeprefix                          <<04.km>>25190000
  else if prefixlen>0 then                                     <<04.km>>25195000
    begin                                                      <<04.km>>25200000
    blankleftfield;                                            <<04.km>>25205000
    move buf:=prefix,(prefixlen);                              <<04.km>>25210000
    writeline;                                                 <<04.km>>25215000
    end;                                                       <<04.km>>25220000
  blankleftfield;                                              <<04.km>>25225000
  while msglen>0 do writeline;                                 <<04.km>>25230000
  cxexit(cce);                                                 <<04.km>>25235000
                                                               <<04.km>>25240000
exitinstr:                                                     <<04.km>>25245000
end <<procedure multiline>>;                                   <<04.km>>25250000
                                                               <<04.km>>25255000
                                                               <<04.km>>25260000
                                                               <<04.km>>25265000
                                                               <<04.km>>25270000
$control  segment=cilistf                                      <<04.km>>25275000
<<********************************************************************>>25280000
<< l i s t f d i s m n t >>                                    <<04.km>>25285000
                                                               <<04.km>>25290000
procedure listfdismnt(mountdst,fatalerr,group,acct,errnum);    <<04.km>>25295000
  value fatalerr;                                              <<04.km>>25300000
  integer mountdst,fatalerr,errnum;                            <<04.km>>25305000
  array group,acct;                                            <<04.km>>25310000
  option privileged,uncallable;                                <<04.km>>25315000
begin                                                          <<04.km>>25320000
  equate catrecsize=   80,                                     <<04.km>>25325000
         maxmsg=       160,                                    <<04.km>>25330000
         namefield=    4,                                      <<04.km>>25335000
         maxprefix=    namefield+22,                           <<04.km>>25340000
         explainfield= maxprefix;                              <<04.km>>25345000
  equate nomount=        0,                                    <<04.km>>25350000
         condmount'bind= -3,                                   <<04.km>>25355000
         singlespace=    0,                                    <<04.km>>25360000
         noparm=         %100000,                              <<04.km>>25365000
         returnit=       -1,                                   <<04.km>>25370000
         stdlist=        2;                                    <<04.km>>25375000
  byte array msg(0:maxmsg-1),                                  <<04.km>>25380000
             prefix(0:maxprefix-1),                            <<04.km>>25385000
             inbuf(0:catrecsize),                              <<04.km>>25390000
             homevs(0:7);                                      <<04.km>>25395000
  byte pointer next,                                           <<04.km>>25400000
               last;                                           <<04.km>>25405000
  integer dummy,                                               <<04.km>>25410000
          prefixlen,                                           <<04.km>>25415000
          req'error,                                           <<04.km>>25420000
          msglen,                                              <<04.km>>25425000
          dstentinfo;                                          <<04.km>>25430000
  logical firsterror:=true;                                    <<04.km>>25435000
                                                               <<04.km>>25440000
  equate dstinfo=  0,                                          <<04.km>>25445000
         ourinfosize= 7;                                       <<04.km>>25450000
  integer array impinfo(0:ourinfosize-1)= q;                   <<04.km>>25455000
  integer implen=     impinfo,                                 <<04.km>>25460000
          impinfolen= implen+1,                                <<04.km>>25465000
          impentlen=  impinfolen+1,                            <<04.km>>25470000
          impentloc=  impentlen+1;                             << i.a >>25475000
                                                               <<04.km>>25480000
  equate ourentsize= 10;                                       <<04.km>>25485000
  integer array entinfo(0:ourentsize-1)= q;                    <<04.km>>25490000
  integer enterr=           entinfo,                           <<04.km>>25495000
          entpvinfo=        enterr+1;                          <<04.km>>25500000
  integer array entname(*)= entpvinfo+1,                       <<04.km>>25505000
                entgrp(*)=  entname,                           <<04.km>>25510000
                entacct(*)= entname+4;                         <<04.km>>25515000
  intrinsic freedseg;                                          <<04.km>>25520000
  integer procedure formsg(ibuf,mset,mnum,pmask,p1,p2,p3,p4,   <<04.km>>25525000
                           p5,obuf,osize,olen,dest,cntl);      <<04.km>>25530000
    value mset,mnum,pmask,p1,p2,p3,p4,p5,osize,dest,cntl;      <<04.km>>25535000
    byte array ibuf,obuf;                                      <<04.km>>25540000
    integer mset,mnum,pmask,p1,p2,p3,p4,p5,osize,olen,dest,    <<04.km>>25545000
            cntl;                                              <<04.km>>25550000
    option external;                                           <<04.km>>25555000
                                                               <<04.km>>25560000
  subroutine def'movefromdseg;                                 <<04.km>>25565000
                                                               <<04.km>>25570000
                                                               <<04.km>>25575000
  <<*******************>>                                      <<04.km>>25580000
  << subroutine append >>                                      <<04.km>>25585000
  <<*******************>>                                      <<04.km>>25590000
                                                               <<04.km>>25595000
  logical subroutine append(name,suffix,buf);                  <<04.km>>25600000
    value suffix; byte array name,buf; integer suffix;         <<04.km>>25605000
  begin                                                        <<04.km>>25610000
    if name(7)=" " then move buf:=name while ans,1             <<04.km>>25615000
    else move buf:=name,(8),2;                                 <<04.km>>25620000
    @last:=tos;                                                <<04.km>>25625000
    last:=suffix;                                              <<04.km>>25630000
    append:=@last(1);                                          <<04.km>>25635000
  end <<subroutine append>>;                                   <<04.km>>25640000
                                                               <<04.km>>25645000
                                                               <<04.km>>25650000
  <<********************>>                                     <<04.km>>25655000
  << subroutine dmerror >>                                     <<04.km>>25660000
  <<********************>>                                     <<04.km>>25665000
                                                               <<04.km>>25670000
  subroutine dmerror(msgset,msgnum,group,acct);                <<04.km>>25675000
    value msgset,msgnum; integer msgset,msgnum;                <<04.km>>25680000
    byte array group,acct;                                     <<04.km>>25685000
  begin                                                        <<04.km>>25690000
    if firsterror then                                         <<04.km>>25695000
      begin                                                    <<04.km>>25700000
      if jobsessionmain then fwrite(stdlist,dummy,0,0);        <<04.km>>25705000
      cierr(-(errnum:=im'mnterr));                             <<04.km>>25710000
      firsterror:=false;                                       <<04.km>>25715000
      end;                                                     <<04.km>>25720000
    if not jobsessionmain or requestservice then return;       <<07.km>>25725000
    @next:=append(group,".",prefix(namefield));                <<04.km>>25730000
    prefixlen:=append(acct,":",next)-logical(@prefix);         <<04.km>>25735000
    msglen:=0;                                                 <<04.km>>25740000
    formsg(inbuf,msgset,msgnum,noparm,0,0,0,0,0,msg,maxmsg,    <<04.km>>25745000
           msglen,returnit,0);                                 <<04.km>>25750000
    multiline(<<file>>,msg,msglen,explainfield,<<fieldlen>>,   <<04.km>>25755000
              singlespace,prefix,prefixlen);                   <<04.km>>25760000
  end <<subroutine dmerror>>;                                  <<04.km>>25765000
                                                               <<04.km>>25770000
                                                               <<04.km>>25775000
  <<*********************>>                                    <<04.km>>25780000
  << main procedure body >>                                    <<04.km>>25785000
  <<*********************>>                                    <<04.km>>25790000
                                                               <<04.km>>25795000
  move prefix:="  *.";                                         <<04.km>>25800000
  if mountdst>0 then                                           <<04.km>>25805000
    begin                                                      <<04.km>>25810000
    movefromdseg(@impinfo,mountdst,dstinfo,ourinfosize);       <<04.km>>25815000
    move homevs:="*       ";                                   <<04.km>>25820000
    for dstentinfo:=impinfolen step impentlen                  <<04.km>>25825000
                    until impentloc-1 do                       <<04.km>>25830000
      begin                                                    <<04.km>>25835000
      movefromdseg(@entinfo,mountdst,dstentinfo,ourentsize);   <<04.km>>25840000
      if enterr<>0 then                                        <<04.km>>25845000
        begin                                                  <<04.km>>25850000
        dmerror(pverrmsgset,enterr,entgrp,entacct)             <<04.km>>25855000
        end                                                    <<04.km>>25860000
      else                                                     <<04.km>>25865000
        begin                                                  <<04.km>>25870000
        req'error:=condmount'bind;                             <<04.km>>25875000
        dismount(homevs,entgrp,entacct,req'error,entpvinfo);   <<04.km>>25880000
        if <> then                                             <<04.km>>25885000
          begin                                                <<04.km>>25890000
          dmerror(pverrmsgset,req'error,entgrp,entacct);       <<04.km>>25895000
          end;                                                 <<04.km>>25900000
        end;                                                   <<04.km>>25905000
      end;                                                     <<04.km>>25910000
    freedseg(mountdst,0);                                      <<04.km>>25915000
    mountdst:=0;                                               <<04.km>>25920000
    end;                                                       <<04.km>>25925000
                                                               <<04.km>>25930000
  if fatalerr>nomount then                                     <<04.km>>25935000
    begin                                                      <<04.km>>25940000
    dmerror(cierrmsgset,im'mnterr+fatalerr,group,acct);        <<04.km>>25945000
    end;                                                       <<04.km>>25950000
end <<procedure listfdismnt>>;                                 <<04.km>>25955000
                                                              <<00.gen>>25960000
                                                              <<00.gen>>25965000
$control  segment=cilistf                                      <<03.km>>25970000
                                                               <<03.km>>25975000
integer procedure dirmatch(designator,realname);              <<00.gen>>25980000
                          value designator,realname;          <<00.gen>>25985000
                          byte pointer designator,            <<00.gen>>25990000
                                       realname;              <<00.gen>>25995000
                          option uncallable;                  <<00.gen>>26000000
begin                                                         <<00.gen>>26005000
  comment:                                                    <<00.gen>>26010000
    compares generic and directory names and returns an       <<00.gen>>26015000
    indicator of the match, viz.:                             <<00.gen>>26020000
                                                              <<00.gen>>26025000
      -1 = initial substring of "DESIGNATOR" is less          <<00.gen>>26030000
           than "REALNAME"                                    <<00.gen>>26035000
       0 = "DESIGNATOR" and "REALNAME" match                  <<00.gen>>26040000
       1 = "DESIGNATOR" and "REALNAME" do not match.          <<00.gen>>26045000
                                                              <<00.gen>>26050000
    note that -1 can be returned only if the initial          <<00.gen>>26055000
    substring of "DESIGNATOR" starts with an alphabetic       <<00.gen>>26060000
    character.                                                <<00.gen>>26065000
                                                              <<00.gen>>26070000
    ascertions:                                               <<00.gen>>26075000
      (1) "DESIGNATOR" contains only alphanumeric, "?",       <<00.gen>>26080000
          "#" and "@" characters                              <<00.gen>>26085000
      (2) "DESIGNATOR" does not contain the sequences         <<00.gen>>26090000
          "@?" & "@@" (these should be converted to           <<00.gen>>26095000
          "?@" & "@" by the pattern builder)                  <<00.gen>>26100000
      (3) "REALNAME" contains only alphanumeric characters    <<00.gen>>26105000
      (4) "DESIGNATOR" & "REALNAME" are 8 bytes long, with    <<00.gen>>26110000
          blank-fill on the right                             <<00.gen>>26115000
      (5) "DESIGNATOR" & "REALNAME" are both the same case,   <<00.gen>>26120000
          viz. upper- or lower-case;                          <<00.gen>>26125000
                                                              <<00.gen>>26130000
                                                              <<00.gen>>26135000
  equate nocode= -2,                                          <<00.gen>>26140000
         ltcode= -1,                                          <<00.gen>>26145000
         eqcode=  0,                                          <<00.gen>>26150000
         gtcode=  1;                                          <<00.gen>>26155000
                                                              <<00.gen>>26160000
  byte pointer dleft,                                         <<00.gen>>26165000
               nleft;                                         <<00.gen>>26170000
  integer x=         x,                                       <<00.gen>>26175000
          matchcode= dirmatch;                                <<00.gen>>26180000
                                                              <<00.gen>>26185000
  array nextq(*)=    q;                <<allocate on tos>>    <<00.gen>>26190000
  byte pointer dptr= nextq,                                   <<00.gen>>26195000
               nptr= dptr+1;                                  <<00.gen>>26200000
  integer length=    nptr+1;                                  <<00.gen>>26205000
                                                              <<00.gen>>26210000
                                                              <<00.gen>>26215000
  <<*************************>>                               <<00.gen>>26220000
  << define lesser'substring >>                               <<00.gen>>26225000
  <<*************************>>                               <<00.gen>>26230000
                                                              <<00.gen>>26235000
  define lesser'substring=                                    <<00.gen>>26240000
    < and (dptr<>special or dptr=" ") #;                      <<00.gen>>26245000
                                                              <<00.gen>>26250000
  <<**************************>>                              <<00.gen>>26255000
  << define reset'matchstart >>                               <<00.gen>>26260000
  <<**************************>>                              <<00.gen>>26265000
                                                              <<00.gen>>26270000
  comment:                                                    <<00.gen>>26275000
    s-2 = @dptr                                               <<00.gen>>26280000
    s-1 = @nptr                                               <<00.gen>>26285000
    s-0 = length of compare.                                  <<00.gen>>26290000
                                                              <<00.gen>>26295000
    back-up pointers so that "@" will match longer            <<00.gen>>26300000
    substring.  "DPTR" is reset to the right of               <<00.gen>>26305000
    last "@".  "NPTR" is reset to the right of last           <<00.gen>>26310000
    initial match determined by "FIND'MATCHSTART";            <<00.gen>>26315000
                                                              <<00.gen>>26320000
  define reset'matchstart=                                    <<00.gen>>26325000
    begin                                                     <<00.gen>>26330000
      @nleft:=@nleft+1;                                       <<00.gen>>26335000
      del; ddel;                                              <<00.gen>>26340000
      tos:=@dleft;                                            <<00.gen>>26345000
      tos:=@nleft;                                            <<00.gen>>26350000
      tos:=@realname(8)-@nleft;                               <<00.gen>>26355000
      dirmatch:=nocode;                                       <<00.gen>>26360000
      find'matchstart;                                        <<00.gen>>26365000
    end <<define reset'matchstart>>#;                         <<00.gen>>26370000
                                                              <<00.gen>>26375000
  <<*********************>>                                   <<00.gen>>26380000
  << define turnofftraps >>                                   <<00.gen>>26385000
  <<*********************>>                                   <<00.gen>>26390000
                                                              <<00.gen>>26395000
  define turnofftraps=                                        <<00.gen>>26400000
    begin                                                     <<00.gen>>26405000
      comment:                                                <<00.gen>>26410000
        avoid integer overflow for byte address               <<00.gen>>26415000
        arithmetic;                                           <<00.gen>>26420000
                                                              <<00.gen>>26425000
      push(status);                                           <<00.gen>>26430000
      tos.(2:1):=0;                                           <<00.gen>>26435000
      set(status);                                            <<00.gen>>26440000
    end <<define turnofftraps>>#;                             <<00.gen>>26445000
                                                              <<00.gen>>26450000
  <<****************>>                                        <<00.gen>>26455000
  << subroutine min >>                                        <<00.gen>>26460000
  <<****************>>                                        <<00.gen>>26465000
                                                              <<00.gen>>26470000
  integer subroutine min(i,j); value i,j; integer i,j;        <<00.gen>>26475000
  begin                                                       <<00.gen>>26480000
    min:=if i<=j then i else j;                               <<00.gen>>26485000
  end <<subroutine min>>;                                     <<00.gen>>26490000
                                                               <<03.km>>26495000
                                                               <<03.km>>26500000
  <<****************************>>                             <<03.km>>26505000
  << subroutine find'matchstart >>                             <<03.km>>26510000
  <<****************************>>                             <<03.km>>26515000
                                                               <<03.km>>26520000
  subroutine find'matchstart;                                  <<03.km>>26525000
  begin                                                        <<03.km>>26530000
    comment:                                                   <<03.km>>26535000
      scan "NPTR" for match with character following           <<03.km>>26540000
      "@" in "DSTR".  save position in "NLEFT" and             <<03.km>>26545000
      set "LENGTH" to length of compare;                       <<03.km>>26550000
                                                               <<03.km>>26555000
    if dptr="#" then                                           <<03.km>>26560000
    begin                                                      <<03.km>>26565000
      while (length:=length-1)>=0 and                          <<03.km>>26570000
            nptr<>numeric do @nptr:=@nptr+1;                   <<03.km>>26575000
    end                                                        <<03.km>>26580000
    else begin                                                 <<03.km>>26585000
      while (length:=length-1)>=0 and                          <<03.km>>26590000
            nptr<>dptr do @nptr:=@nptr+1;                      <<03.km>>26595000
    end;                                                       <<03.km>>26600000
                                                               <<03.km>>26605000
    length:=length+1;                                          <<03.km>>26610000
    if <= then dirmatch:=gtcode                                <<03.km>>26615000
    else begin                                                 <<03.km>>26620000
      @nleft:=@nptr;                                           <<03.km>>26625000
      length:=min(@designator(8)-@dptr, @realname(8)-@nptr);   <<03.km>>26630000
    end;                                                       <<03.km>>26635000
  end <<subroutine find'matchstart>>;                          <<03.km>>26640000
                                                               <<03.km>>26645000
                                                               <<03.km>>26650000
  <<**************************>>                               <<03.km>>26655000
  << subroutine check'endcond >>                               <<03.km>>26660000
  <<**************************>>                               <<03.km>>26665000
                                                               <<03.km>>26670000
  subroutine check'endcond;                                    <<03.km>>26675000
  begin                                                        <<03.km>>26680000
    comment:                                                   <<03.km>>26685000
      ensure that both "DPTR" and "NPTR" strings are           <<03.km>>26690000
      exhausted.  if eqcode, then at least one string          <<03.km>>26695000
      is exhausted;                                            <<03.km>>26700000
                                                               <<03.km>>26705000
    if matchcode=eqcode then                                   <<03.km>>26710000
    begin                                                      <<03.km>>26715000
      if @dptr=@designator(8) then                             <<03.km>>26720000
      begin                                                    <<03.km>>26725000
        if @nptr<>@realname(8) and                             <<03.km>>26730000
           nptr<>" " then dirmatch:=gtcode;                    <<03.km>>26735000
      end                                                      <<03.km>>26740000
      else                                                     <<03.km>>26745000
        if dptr<>" " then                                      <<03.km>>26750000
        begin                                                  <<03.km>>26755000
          if dptr<>"@" or                                      <<03.km>>26760000
             @dptr<>@designator(7) and                         <<03.km>>26765000
             dptr(1)<>" " then dirmatch:=gtcode;               <<03.km>>26770000
        end;                                                   <<03.km>>26775000
    end;                                                       <<03.km>>26780000
  end <<subroutine check'endcond>>;                            <<03.km>>26785000
                                                              <<00.gen>>26790000
  <<********************>>                                    <<00.gen>>26795000
  << subroutine closure >>                                    <<00.gen>>26800000
  <<********************>>                                    <<00.gen>>26805000
                                                              <<00.gen>>26810000
  logical subroutine closure;                                 <<00.gen>>26815000
  begin                                                       <<00.gen>>26820000
    comment:                                                  <<00.gen>>26825000
      return "TRUE" if we've encountered an embedded          <<00.gen>>26830000
      "@" (closure wildcard).  we assume that we've           <<00.gen>>26835000
      done a "SIMPLEMATCH" first.  thus, failure to           <<00.gen>>26840000
      find closure wildcard means that no further             <<00.gen>>26845000
      match is possible (match=gtcode).  note that            <<00.gen>>26850000
      if closure wildcard is at the end of "DPTR",            <<00.gen>>26855000
      the match is done (match=eqcode) since it will          <<00.gen>>26860000
      match remainder of "NPTR";                              <<00.gen>>26865000
                                                              <<00.gen>>26870000
    closure:=false;                                           <<00.gen>>26875000
    if matchcode=nocode then                                  <<00.gen>>26880000
    begin                                                     <<00.gen>>26885000
      if dptr<>"@" then dirmatch:=gtcode                      <<00.gen>>26890000
      else                                                    <<00.gen>>26895000
        if @dptr=@designator(7) or                            <<00.gen>>26900000
           dptr(1)=" " then dirmatch:=eqcode                  <<00.gen>>26905000
      else if nptr=" " then dirmatch:=gtcode                  <<00.gen>>26910000
      else begin                                              <<00.gen>>26915000
        @dptr:=@dptr+1;                                       <<00.gen>>26920000
        @dleft:=@dptr;                                        <<00.gen>>26925000
        @nleft := @nptr;                                       <<01516>>26930000
        length:=@realname(8)-@nptr;                           <<00.gen>>26935000
        find'matchstart;                                      <<00.gen>>26940000
        if matchcode=nocode then closure:=true;               <<00.gen>>26945000
      end;                                                    <<00.gen>>26950000
    end;                                                      <<00.gen>>26955000
  end <<subroutine closure>>;                                 <<00.gen>>26960000
                                                              <<00.gen>>26965000
  <<************************>>                                <<00.gen>>26970000
  << subroutine simplematch >>                                <<00.gen>>26975000
  <<************************>>                                <<00.gen>>26980000
                                                              <<00.gen>>26985000
  subroutine simplematch;                                     <<00.gen>>26990000
  begin                                                       <<00.gen>>26995000
    comment:                                                  <<00.gen>>27000000
      s-3 = @dptr                                             <<00.gen>>27005000
      s-2 = @nptr                                             <<00.gen>>27010000
      s-1 = length of compare                                 <<00.gen>>27015000
      s-0 = "SIMPLEMATCH" return address.                     <<00.gen>>27020000
                                                              <<00.gen>>27025000
      match alphanumeric characters and single-byte           <<00.gen>>27030000
      wildcard characters ("?" and "#");                      <<00.gen>>27035000
                                                              <<00.gen>>27040000
    x:=tos;                            <<save retn addr>>     <<00.gen>>27045000
    do begin                                                  <<00.gen>>27050000
      if * <> *,(tos),0 then                                  <<00.gen>>27055000
      begin                                                   <<00.gen>>27060000
  loop:                                                       <<00.gen>>27065000
        if dptr="?" and nptr<>special or                      <<00.gen>>27070000
           dptr="#" and nptr=numeric then                     <<00.gen>>27075000
        begin                                                 <<00.gen>>27080000
          @dptr:=@dptr+1;                                     <<00.gen>>27085000
          assemble(incb,deca);                                <<00.gen>>27090000
          if <> then go loop;                                 <<00.gen>>27095000
        end;                                                  <<00.gen>>27100000
      end;                                                    <<00.gen>>27105000
    end until length=0 or dptr<>nptr;                         <<00.gen>>27110000
    if = then dirmatch:=eqcode;        <<length=0>>           <<00.gen>>27115000
    tos:=x;                            <<reset retn addr>>    <<00.gen>>27120000
  end <<subroutine simplematch>>;                             <<00.gen>>27125000
                                                              <<00.gen>>27130000
                                                              <<00.gen>>27135000
  <<***********************>>                                 <<00.gen>>27140000
  <<                       >>                                 <<00.gen>>27145000
  << begin procedure match >>                                 <<00.gen>>27150000
  <<                       >>                                 <<00.gen>>27155000
  <<***********************>>                                 <<00.gen>>27160000
                                                              <<00.gen>>27165000
  turnofftraps;                                               <<00.gen>>27170000
  if designator=realname,(8),0 then dirmatch:=eqcode          <<00.gen>>27175000
  else if lesser'substring then dirmatch:=ltcode              <<00.gen>>27180000
  else begin                                                  <<00.gen>>27185000
    comment:                                                  <<00.gen>>27190000
      s-2 = @dptr                                             <<00.gen>>27195000
      s-1 = @nptr                                             <<00.gen>>27200000
      s-0 = compare length;                                   <<00.gen>>27205000
                                                              <<00.gen>>27210000
    dirmatch:=nocode;                                         <<00.gen>>27215000
    simplematch;                                              <<00.gen>>27220000
    if closure then                                           <<00.gen>>27225000
    begin                                                     <<00.gen>>27230000
      do begin                                                <<00.gen>>27235000
        do simplematch until not closure;                     <<00.gen>>27240000
        check'endcond;                                        <<00.gen>>27245000
        if matchcode<>eqcode then reset'matchstart;           <<00.gen>>27250000
      end until matchcode<>nocode;                             <<01454>>27255000
    end;                                                       <<01454>>27260000
  end;                                                         <<01454>>27265000
end <<procedure dirmatch>>;                                    <<01454>>27270000
                                                               <<01454>>27275000
                                                               <<01454>>27280000
                                                               <<01454>>27285000
procedure get'filecode(filecode,mnemonic,mnemonic'length);     <<01454>>27290000
   integer filecode,mnemonic'length;                           <<01454>>27295000
   byte array mnemonic;                                        <<01454>>27300000
   option privileged,uncallable;                               <<01454>>27305000
                                                               <<01454>>27310000
comment                                                        <<01454>>27315000
   this procedure contains two entry points for converting file<<01454>>27320000
   code mnemonics to file code values and vice versa.          <<01454>>27325000
                                                               <<01454>>27330000
get'filecode                                                   <<01454>>27335000
   this entry point takes a character string, compares it to   <<01454>>27340000
   a list of hp defined file code mnemonics, and returns the   <<01454>>27345000
   integer value of the corresponding file code.               <<01454>>27350000
                                                               <<01454>>27355000
   input                                                       <<01454>>27360000
      mnemonic -- byte array containing the character string.  <<01454>>27365000
      mnemonic'length -- length of the character string        <<01454>>27370000
         contained in mnemonic.  must be > 0.                  <<01454>>27375000
   output                                                      <<01454>>27380000
      filecode -- integer file code corresponding to the string<<01454>>27385000
         passed in mnemonic.  if there is no hp defined file   <<01454>>27390000
         code corresponding to the input string, the value     <<01454>>27395000
         returned in filecode is 0.                            <<01454>>27400000
   condition code                                              <<01454>>27405000
      cce -- string passed is an hp defined file code mnemonic.<<01454>>27410000
      ccg -- string passed is not an hp defined mnemonic.      <<01454>>27415000
      ccl -- error in call, length <= 0.                       <<01454>>27420000
                                                               <<01454>>27425000
get'filemnemonic                                               <<01454>>27430000
   this entry point takes an integer value, compares it to a   <<01454>>27435000
   list of hp defined file codes, and returns the mnemonic     <<01454>>27440000
   corresponding to the input value.                           <<01454>>27445000
                                                               <<01454>>27450000
   input                                                       <<01454>>27455000
      filecode -- integer file code.                           <<01454>>27460000
   output                                                      <<01454>>27465000
      mnemonic -- 5 character mnemonic corresponding to the    <<01454>>27470000
         input value.  the mnemonic is left-justified with     <<01454>>27475000
         trailing blanks.  if the file code does not have a    <<01454>>27480000
         corresponding mnemonic, the string is all blanks.     <<01454>>27485000
      mnemonic'length -- the number of non-blank characters    <<01454>>27490000
         returned in mnemonic.                                 <<01454>>27495000
   condition code                                              <<01454>>27500000
      cce -- the input value had a corresponding mnemonic.     <<01454>>27505000
      ccg -- no mnemonic for file code value.                  <<01454>>27510000
      ccl -- not returned.                                     <<01454>>27515000
                                                               <<01454>>27520000
issues                                                         <<01454>>27525000
   1)  the dictionary entries are of fixed length so that they <<01454>>27530000
       can be indexed.                                         <<01454>>27535000
   2)  the search for get'filemnemonic is faster than the      <<01454>>27540000
       search for get'filecode because listf's are done more   <<01454>>27545000
       frequently than file or build commands.                 <<01454>>27550000
                                                               <<01454>>27555000
adding a new mnemonic                                          <<01454>>27560000
   1)  change number'codes to reflect the new number of        <<01454>>27565000
       mnemonics.                                              <<01454>>27570000
   2)  insert an entry into both the dictionary and the the    <<01454>>27575000
       file code array so that the indices match.              <<01454>>27580000
;                                                              <<01454>>27585000
                                                               <<01454>>27590000
                                                               <<01454>>27595000
                                                               <<01454>>27600000
begin                                                          <<01454>>27605000
   entry get'filemnemonic;                                     <<01454>>27610000
                                                               <<01454>>27615000
   byte array local'buffer(0:7);                               <<01454>>27620000
                                                               <<01454>>27625000
   integer entry'number,  << index of entry >>                 <<01454>>27630000
           lower'bound,   << bounds for binary search >>       <<01454>>27635000
           upper'bound;                                        <<01454>>27640000
                                                               <<01454>>27645000
<< number'codes -- the number of file codes and associated >>  <<01454>>27650000
<<    mnemonics contained in the two data structures.      >>  <<01454>>27655000
                                                               <<01454>>27660000
   equate number'codes = 87,                                   << 8084>>27665000
          dict'length = number'codes*8 + 1;                    <<01454>>27670000
                                                               <<01454>>27675000
   byte array local'dict(0:dict'length-1);                     <<01454>>27680000
                                                               <<01454>>27685000
<< mnemonic'dict -- a byte array formatted for use by the    >><<01454>>27690000
<<    search intrinsic.  the "name" portion of each entry is >><<01454>>27695000
<<    five characters containing a file code mnemonic left-  >><<01454>>27700000
<<    justified with trailing blanks.  the definition        >><<01454>>27705000
<<    portion of each entry is the length of the mnemonic.   >><<01454>>27710000
                                                               <<01454>>27715000
   byte array mnemonic'dict(0:dict'length-1) = pb :=           <<01454>>27720000
                                                               <<01454>>27725000
8,5,"USL  ",3,     << 1024 >>                                  <<01454>>27730000
8,5,"BASD ",4,     << 1025 >>                                  <<01454>>27735000
8,5,"BASP ",4,     << 1026 >>                                  <<01454>>27740000
8,5,"BASFP",5,     << 1027 >>                                  <<01454>>27745000
8,5,"RL   ",2,     << 1028 >>                                  <<01454>>27750000
8,5,"PROG ",4,     << 1029 >>                                  <<01454>>27755000
8,5,"SL   ",2,     << 1031 >>                                  <<01454>>27760000
8,5,"VFORM",5,     << 1035 >>                                  <<01454>>27765000
8,5,"VFAST",5,     << 1036 >>                                  <<01454>>27770000
8,5,"VREF ",4,     << 1037 >>                                  <<01454>>27775000
8,5,"XLSAV",5,     << 1040 >>                                  <<01454>>27780000
8,5,"XLBIN",5,     << 1041 >>                                  <<01454>>27785000
8,5,"XLDSP",5,     << 1042 >>                                  <<01454>>27790000
8,5,"EDITQ",5,     << 1050 >>                                  <<01454>>27795000
8,5,"EDTCQ",5,     << 1051 >>                                  <<01454>>27800000
8,5,"EDTCT",5,     << 1052 >>                                  <<01454>>27805000
8,5,"TDPDT",5,     << 1054 >>                                           27810000
8,5,"TDPQM",5,     << 1055 >>                                           27815000
8,5,"TDPP ",4,     << 1056 >>                                           27820000
8,5,"TDPCP",5,     << 1057 >>                                           27825000
8,5,"TDPQ ",4,     << 1058 >>                                           27830000
8,5,"TDPXQ",5,     << 1059 >>                                           27835000
8,5,"RJEPN",5,     << 1060 >>                                  <<01454>>27840000
8,5,"QPROC",5,     << 1070 >>                                  <<01454>>27845000
8,5,"KSAMK",5,     << 1080 >>                                  <<01454>>27850000
8,5,"GRAPH",5,     << 1083 >>                                  <<01454>>27855000
8,5,"SD   ",2,     << 1084 >>                                  <<01454>>27860000
8,5,"LOG  ",3,     << 1090 >>                                  <<01454>>27865000
8,5,"WDOC ",4,     << 1100 >>                                  <<01454>>27870000
8,5,"WDICT",5,     << 1101 >>                                  <<01454>>27875000
8,5,"WCONF",5,     << 1102 >>                                  <<04783>>27880000
8,5,"W2601",5,     << 1103 >>                                  <<04783>>27885000
8,5,"PCELL",5,     << 1110 >>                                  <<01454>>27890000
8,5,"PFORM",5,     << 1111 >>                                  <<01454>>27895000
8,5,"PENV ",4,     << 1112 >>                                  <<06843>>27900000
8,5,"PCCMP",5,     << 1113 >>                                  <<01454>>27905000
8,5,"RASTR",5,     << 1114 >>                                  <<04783>>27910000
8,5,"OPTLF",5,     << 1130 >>                                  <<01652>>27915000
8,5,"TEPES",5,     << 1131 >>                                  <<01454>>27920000
8,5,"TEPEL",5,     << 1132 >>                                  <<01454>>27925000
8,5,"SAMPL",5,     << 1133 >>                                  <<04783>>27930000
8,5,"MPEDL",5,     << 1139 >>                                  <<04783>>27935000
8,5,"TSR  ",3,     << 1140 >>                                  <<04783>>27940000
8,5,"TSD  ",3,     << 1141 >>                                  <<04783>>27945000
8,5,"DRAW ",4,     << 1145 >>                                  <<04783>>27950000
8,5,"FIG  ",3,     << 1146 >>                                           27955000
8,5,"FONT ",4,     << 1147 >>                                  <<06843>>27960000
8,5,"COLOR",5,     << 1148 >>                                  <<07276>>27965000
8,5,"D48  ",3,     << 1149 >>                                  <<07276>>27970000
8,5,"SLATE",5,     << 1152 >>                                  << 7794>>27975000
8,5,"SLATW",5,     << 1153 >>                                  << 7794>>27980000
8,5,"DSTOR",5,     << 1156 >>                                  <<04783>>27985000
8,5,"TCODE",5,     << 1157 >>                                  <<04783>>27990000
8,5,"RCODE",5,     << 1158 >>                                  <<04783>>27995000
8,5,"ICODE",5,     << 1159 >>                                  <<04783>>28000000
8,5,"MDIST",5,     << 1166 >>                                  <<04783>>28005000
8,5,"MTEXT",5,     << 1167 >>                                  <<04783>>28010000
8,5,"VCSF ",4,     << 1176 >>                                  <<04783>>28015000
8,5,"TTYPE",5,     << 1177 >>                                  <<04783>>28020000
8,5,"TVFC ",4,     << 1178 >>                                           28025000
8,5,"NCONF",5,     << 1192 >>                                  <<04783>>28030000
8,5,"NTRAC",5,     << 1193 >>                                  <<04783>>28035000
8,5,"NLOG ",4,     << 1194 >>                                  <<04783>>28040000
8,5,"MIDAS",5,     << 1195 >>                                  <<04783>>28045000
8,5,"ANODE",5,     << 1211 >>                                  << 8084>>28050000
8,5,"INODE",5,     << 1212 >>                                  << 8084>>28055000
8,5,"INVRT",5,     << 1213 >>                                  << 8084>>28060000
8,5,"EXCEP",5,     << 1214 >>                                  << 8084>>28065000
8,5,"TAXON",5,     << 1215 >>                                  << 8084>>28070000
8,5,"QUERF",5,     << 1216 >>                                  << 8084>>28075000
8,5,"DOCDR",5,     << 1217 >>                                  << 8084>>28080000
8,5,"VC   ",2,     << 1226 >>                                  <<06843>>28085000
8,5,"DIF  ",3,     << 1227 >>                                  <<06843>>28090000
8,5,"LANGD",5,     << 1228 >>                                  <<06843>>28095000
8,5,"CHARD",5,     << 1229 >>                                  <<06843>>28100000
8,5,"MGCAT",5,     << 1230 >>                                  <<06843>>28105000
8,5,"ATLAS",5,     << 1235 >>                                  << 7794>>28110000
8,5,"BMAP ",4,     << 1236 >>                                  <<06843>>28115000
8,5,"BDATA",5,     << 1242 >>                                  << 7794>>28120000
8,5,"BFORM",5,     << 1243 >>                                  << 7794>>28125000
8,5,"BSAVE",5,     << 1244 >>                                  << 7794>>28130000
8,5,"BCNFG",5,     << 1245 >>                                  << 7794>>28135000
8,5,"PFJOB",5,     << 1257 >>                                  << 7794>>28140000
8,5,"PFTAB",5,     << 1258 >>                                  << 7794>>28145000
8,5,"PFDYN",5,     << 1259 >>                                  << 7794>>28150000
8,5,"PFSRC",5,     << 1260 >>                                  << 7794>>28155000
8,5,"CWPTX",5,     << 1401 >>                                  << 8084>>28160000
0;                                                             <<01454>>28165000
                                                               <<01454>>28170000
<< mnemonic'code -- an ascending ordered integer array       >><<01454>>28175000
<<    containing those hp defined file codes which have a    >><<01454>>28180000
<<    corresponding mnemonic.  the index of each element     >><<01454>>28185000
<<    corresponds to the entry number returned by the search >><<01454>>28190000
<<    intrinsic for its mnemonic.                            >><<01454>>28195000
                                                               <<01454>>28200000
   integer array mnemonic'code(1:number'codes) = pb :=         <<01454>>28205000
                                                               <<01454>>28210000
1024      << usl   >>                                          <<01454>>28215000
,1025     << basd  >>                                          <<01454>>28220000
,1026     << basp  >>                                          <<01454>>28225000
,1027     << basfp >>                                          <<01454>>28230000
,1028     << rl    >>                                          <<01454>>28235000
,1029     << prog  >>                                          <<01454>>28240000
,1031     << sl    >>                                          <<01454>>28245000
,1035     << vform >>                                          <<01454>>28250000
,1036     << vfast >>                                          <<01454>>28255000
,1037     << vref  >>                                          <<01454>>28260000
,1040     << xlsav >>                                          <<01454>>28265000
,1041     << xlbin >>                                          <<01454>>28270000
,1042     << xldsp >>                                          <<01454>>28275000
,1050     << editq >>                                          <<01454>>28280000
,1051     << edtcq >>                                          <<01454>>28285000
,1052     << edtct >>                                          <<01454>>28290000
<< 1053:       reserved for edit extensions >>                          28295000
,1054     << tdpdt >>                                                   28300000
,1055     << tdpqm >>                                                   28305000
,1056     << tdpp  >>                                                   28310000
,1057     << tdpcp >>                                                   28315000
,1058     << tdpq  >>                                                   28320000
,1059     << tdpcq >>                                                   28325000
,1060     << rjepn >>                                          <<01454>>28330000
<< 1061-1069:  reserved for rje extensions >>                  <<01454>>28335000
,1070     << qproc >>                                          <<01454>>28340000
<< 1071&1072 -- query work files >>                            <<01454>>28345000
<< 1073-1079:  reserved for query extensions >>                <<01454>>28350000
,1080     << ksamk >>                                          <<01454>>28355000
,1083     << graph >>                                          <<01454>>28360000
,1084     << sd    >>                                          <<01454>>28365000
,1090     << log   >>                                          <<01454>>28370000
,1100     << wdoc  >>                                          <<01454>>28375000
,1101     << wdict >>                                          <<01454>>28380000
,1102     << wconf >>                                          <<04783>>28385000
,1103     << w2601 >>                                          <<04783>>28390000
<< 1104-1109: reserved for word extensions >>                  <<04783>>28395000
,1110     << pcell >>                                          <<01454>>28400000
,1111     << pform >>                                          <<01454>>28405000
,1112     << penv  >>                                          <<06843>>28410000
,1113     << pccmp >>                                          <<01454>>28415000
,1114     << rastr >>                                          <<04783>>28420000
<< 1115-1129: reserved for psp extensions >>                   <<04783>>28425000
,1130     << optlf >>                                          <<01652>>28430000
,1131     << tepes >>                                          <<01454>>28435000
,1132     << tepel >>                                          <<01454>>28440000
,1133     << sampl >>                                          <<04783>>28445000
<< 1134-1138: reserved for perf. tools extensions >>           <<04783>>28450000
,1139     << mpedl >>                                          <<04783>>28455000
,1140     << tsr   >>                                          <<04783>>28460000
,1141     << tsd   >>                                          <<04783>>28465000
<< 1142-1144: reserved for toolset extensions >>               <<04783>>28470000
,1145     << draw  >>                                          <<04783>>28475000
,1146     << fig   >>                                                   28480000
,1147     << font  >>                                          <<06843>>28485000
,1148     << color >>                                          <<07276>>28490000
,1149     << d48   >>                                          <<07276>>28495000
,1152     << slate >>                                          << 7794>>28500000
,1153     << slatw >>                                          << 7794>>28505000
<< 1150,1151,1154,1155: reserved for slate >>                  << 7794>>28510000
,1156     << dstor >>                                          <<04783>>28515000
,1157     << tcode >>                                          <<04783>>28520000
,1158     << rcode >>                                          <<04783>>28525000
,1159     << icode >>                                          <<04783>>28530000
<< 1160-1165: reserved for rapid >>                            <<04783>>28535000
,1166     << mdist >>                                          <<04783>>28540000
,1167     << mtext >>                                          <<04783>>28545000
<< 1168-1170: reserved for hpmail >>                           <<04783>>28550000
,1176     << vcsf  >>                                          <<04783>>28555000
,1177     << ttype >>                                          <<04783>>28560000
,1178     << tvfc  >>                                                   28565000
<< 1178-1186: reserved for terminal i/o >>                     <<04783>>28570000
<< 1187-1191: reserved for ds >>                               <<04783>>28575000
,1192     << nconf >>                                          <<04783>>28580000
,1193     << ntrac >>                                          <<04783>>28585000
,1194     << nlog  >>                                          <<04783>>28590000
,1195     << midas >>                                          <<04783>>28595000
<< 1196-1199: reserved for ds network management >>            <<04783>>28600000
<< 1200-1210: reserved for kanji >>                            <<04783>>28605000
,1211     << anode >>                                          << 8084>>28610000
,1212     << inode >>                                          << 8084>>28615000
,1213     << invrt >>                                          << 8084>>28620000
,1214     << excep >>                                          << 8084>>28625000
,1215     << taxon >>                                          << 8084>>28630000
,1216     << querf >>                                          << 8084>>28635000
,1217     << docdr >>                                          << 8084>>28640000
<< 1218-1224: reserved for ds'83 >>                            << 8084>>28645000
,1226     << vc    >>                                          <<06843>>28650000
,1227     << dif   >>                                          <<06843>>28655000
,1228     << langd >>                                          <<06843>>28660000
,1229     << chard >>                                          <<06843>>28665000
,1230     << mgcat >>                                          <<06843>>28670000
<< 1231-1232: reserved for native language support >>          <<06843>>28675000
<< 1233-1234: reserved for horizon >>                          <<06843>>28680000
,1235     << atlas >>                                          <<07276>>28685000
,1236     << bmap  >>                                          <<06843>>28690000
<< 1237-1241: reserved for tdp >>                              << 7794>>28695000
,1242     << bdata >>                                          << 7794>>28700000
,1243     << bform >>                                          << 7794>>28705000
,1244     << bsave >>                                          << 7794>>28710000
,1245     << bcnfg >>                                          << 7794>>28715000
<< 1246-1256: reserved for hp business basic >>                << 7794>>28720000
,1257     << pfjob >>                                          << 7794>>28725000
,1258     << pftab >>                                          << 7794>>28730000
,1259     << pfdyn >>                                          << 7794>>28735000
,1260     << pfsrc >>                                          << 7794>>28740000
<< 1261-1264: reserved for pathflow >>                         << 7794>>28745000
<< 1265-1400: reserved for roseville >>                        << 7794>>28750000
,1401     << cwptx >>                                          << 8084>>28755000
<< 1402-1420: reserved for taiwan applications center >>       << 8084>>28760000
;                                                              <<01454>>28765000
                                                               <<01454>>28770000
                                                               <<01454>>28775000
subroutine binary'search;                                      <<01454>>28780000
begin                                                          <<01454>>28785000
   << initialize loop variables >>                             <<01454>>28790000
   lower'bound := 1;                                           <<01454>>28795000
   upper'bound := number'codes;                                <<01454>>28800000
                                                               <<01454>>28805000
   while lower'bound <= upper'bound do                         <<01454>>28810000
      begin                                                    <<01454>>28815000
      x := (lower'bound + upper'bound)/2;                      <<01454>>28820000
                                                               <<01454>>28825000
      if filecode < mnemonic'code(x) then                      <<01454>>28830000
         upper'bound := x - 1     << less than case >>         <<01454>>28835000
      else if > then                                           <<01454>>28840000
         lower'bound := x + 1     << greater than case >>      <<01454>>28845000
      else                                                     <<01454>>28850000
         begin                                                 <<01454>>28855000
         entry'number := x;       << found entry >>            <<01454>>28860000
         return;                                               <<01454>>28865000
         end;                                                  <<01454>>28870000
      end;                << of search loop >>                 <<01454>>28875000
                                                               <<01454>>28880000
   entry'number := 0;     << entry not found >>                <<01454>>28885000
                                                               <<01454>>28890000
end;      << of binary'search >>                               <<01454>>28895000
                                                               <<01454>>28900000
                                                               <<01454>>28905000
                                                               <<01454>>28910000
<< entry point for get'filecode >>                             <<01454>>28915000
                                                               <<01454>>28920000
   cc := ccl;           << set cond code for error case >>     <<01454>>28925000
                                                               <<01454>>28930000
   << length must be positive >>                               <<01454>>28935000
   if mnemonic'length <= 0 then return;         << ccl >>      <<01454>>28940000
                                                               <<01454>>28945000
   << initialize variables for not found case >>               <<01454>>28950000
   filecode := 0;                                              <<01454>>28955000
   cc := ccg;                                                  <<01454>>28960000
                                                               <<01454>>28965000
   << no mnemonics > 5 characters >>                           <<01454>>28970000
   if mnemonic'length > 5 then return;          << ccg >>      <<01454>>28975000
                                                               <<01454>>28980000
   << get local copy of mnemonic upshifted >>                  <<01454>>28985000
   move local'buffer := "      ";                              <<01454>>28990000
   move local'buffer := mnemonic,(mnemonic'length);            <<01454>>28995000
   move local'buffer := local'buffer while ans;                <<01454>>29000000
                                                               <<01454>>29005000
   << search for mnemonic in dictionary >>                     <<01454>>29010000
   move local'dict := mnemonic'dict,(dict'length);             <<01454>>29015000
   entry'number := search(local'buffer,5,local'dict);          <<01454>>29020000
                                                               <<01454>>29025000
   if entry'number <> 0 then                                   <<01454>>29030000
      begin              << found mnemonic >>                  <<01454>>29035000
      cc := cce;                                               <<01454>>29040000
      filecode := mnemonic'code(entry'number);                 <<01454>>29045000
      end;                                                     <<01454>>29050000
                                                               <<01454>>29055000
   return;         << all done with get'filecode entry point >><<01454>>29060000
                                                               <<01454>>29065000
                                                               <<01454>>29070000
get'filemnemonic:                                              <<01454>>29075000
                                                               <<01454>>29080000
   << initialize output variables for not found case >>        <<01454>>29085000
   cc := ccg;                                                  <<01454>>29090000
   mnemonic'length := 0;                                       <<01454>>29095000
   move mnemonic := "     ";                                   <<01454>>29100000
                                                               <<01454>>29105000
   << check if file code in range of possible mnemonics >>     <<01454>>29110000
   if mnemonic'code(1) <= filecode <=                          <<01454>>29115000
      mnemonic'code(number'codes) then                         <<01454>>29120000
      begin                                                    <<01454>>29125000
      binary'search;     << binary'search sets entry'number >> <<01454>>29130000
                                                               <<01454>>29135000
      if entry'number <> 0 then                                <<01454>>29140000
         begin                << found code >>                 <<01454>>29145000
                                                               <<01454>>29150000
         << get local copy of dictionary entry >>              <<01454>>29155000
         move local'buffer :=                                  <<01454>>29160000
              mnemonic'dict( (entry'number-1)*8 ),(8);         <<01454>>29165000
                                                               <<01454>>29170000
         << set return variables >>                            <<01454>>29175000
         cc := cce;                                            <<01454>>29180000
         move mnemonic := local'buffer(2),(5);                 <<01454>>29185000
         mnemonic'length := local'buffer(7);                   <<01454>>29190000
         end;                                                  <<01454>>29195000
      end;                                                     <<01454>>29200000
                                                               <<01454>>29205000
                                                               <<01454>>29210000
end;     << of get'filecode/mnemonic >>                        <<01454>>29215000
                                                               <<01454>>29220000
                                                               <<01454>>29225000
integer procedure listfile (parms);                           <<00.gen>>29230000
   integer array parms;                                       <<00.gen>>29235000
   option privileged, uncallable;                                       29240000
begin                                                                   29245000
                                                                        29250000
   double array      dparms (*)        = parms;                         29255000
<< "OWN" variables in <parms>. >>                                       29260000
   integer array     fname (*)         = parms,                         29265000
                     currentg (*)      = parms (4),                     29270000
                     currenta (*)      = parms (8),                     29275000
                     currentga (*)     = currentg;                      29280000
   define            detail            = parms (12) #,                  29285000
                     detaillength      = parms (13) #,   <<words>>      29290000
                     fpntr1            = parms (14) #,                  29295000
                     fpntr2            = parms (15) #,                  29300000
                     sirs              = dparms (8) #,                  29305000
                     filenum           = parms (18) #,                  29310000
                     devsize           = parms (19) #,   <<bytes>>      29315000
                     lineno            = parms (20) #,                  29320000
                     numperlinecount   = parms (21) #,         <<rv.pv>>29325000
                     glinkagew         = parms (23) #;         << i.a >>29330000
                                                                        29335000
<< locals >>                                                            29340000
   equate            maxdetaillength   = 72,                            29345000
                     mdlwordsm1        = maxdetaillength/2 -1,          29350000
                     finfosize         = 128,                           29355000
                     longdev           = 128;                           29360000
   integer array     flabel (*),                                        29365000
                     buf (0:mdlwordsm1);                                29370000
   double array      dflabel (*)       = flabel;                        29375000
   byte array        bbuf (*)          = buf,                           29380000
                     tbuf (0:9);                                        29385000
   integer           len,                                               29390000
                     bf,                                                29395000
                     nx;                                                29400000
   logical           firstfile := false,  << 1st in group >>   <<01724>>29405000
                     badflabel := false;  << bad file label >> <<01724>>29410000
   << double (tos) / x  --->  double (q), single (rem)    (on tos) >>   29415000
   << double (tos) * x  --->  double (product)  (on tos) >>             29420000
                                                                        29425000
<< file label >>                                                        29430000
   << following 3 array addresses are set when (if) <flabel> is intitl>>29435000
integer array     flga (*)       << = flabel (4) >>;           <<0307>> 29440000
double array      flextmap (*)   << = flabel (44) >>;          <<0307>> 29445000
   byte array        bflga (*)      << = flga >>;                       29450000
   define            flflim            = dflabel (15) #,                29455000
                     fleof             = dflabel (21) #,                29460000
                     flcode            = flabel (26) #,                 29465000
                     flopened          = dflabel(16) <> 0d and <<06569>>29470000
                         flabel (35) =absolute(coldloadid) #,           29475000
                     flrecformat       = flabel (36) .(8:2) #,          29480000
                     flascii           = logical (flabel(36).(13:1)) #, 29485000
                     flcntrl           = logical (flabel(36).(7:1)) #,  29490000
                     flfiletype    =logical(flabel(36).(2:3))#,<<01549>>29495000
                     flksam            = (flfiletype = 1) #,   <<01549>>29500000
                     flmsgfile         = (flfiletype = 6) #,   <<01549>>29505000
                     flrecsize         = flabel (37) #,                 29510000
                     flblksize         = flabel (38) #,                 29515000
                     flnumexts         = flabel (39) .(11:5) #,         29520000
                  fllastextsize     = flabel (40) #,           <<0307>> 29525000
                     flextsize         = flabel (41) #;                 29530000
   byte array        priv (0:4) = pb   := "PRIV ";                      29535000
   array             filetype(0:7)=pb:="     R ? O ? M ?";     <<01549>>29540000
                                                                        29545000
<< misc. junk >>                                                        29550000
      define                                                            29555000
                     eject             = begin                          29560000
                                         fwrite (filenum, buf, 0, %61); 29565000
                                         if <> then                     29570000
                                            begin                       29575000
                                            tos := 2;                   29580000
                                            goto exit;                  29585000
                                            end;                        29590000
                                         lineno := 1;                   29595000
                                         end  #,                        29600000
                     finishwrite       = if <> then                     29605000
                                            begin                       29610000
                                            tos := 2;                   29615000
                                            goto exit;                  29620000
                                            end;                        29625000
                                         lineno := lineno  #,           29630000
                     space             = begin                          29635000
                                         fwrite (filenum, buf, 0, %40); 29640000
                                         finishwrite +1;                29645000
                                         end #,                         29650000
                     dspace            = begin                          29655000
                                         fwrite (filenum, buf, 0, %60); 29660000
                                         finishwrite +2;                29665000
                                         end #;                         29670000
                                                                        29675000
<< list format >>                                                       29680000
   array             title1 (0:33) = pb :=  "FILENAME",        <<u.rao>>29685000
"  CODE  ------------LOGICAL RECORD-----------  ----SPACE----";<<u.rao>>29690000
   array             title1a (0:33) = pb := "        ",        <<u.rao>>29695000
"          SIZE  TYP        EOF      LIMIT R/B  SECTORS #X MX";<<u.rao>>29700000
   equate            oppos             = 8,                             29705000
                     codepos           = 10,                            29710000
                     rsizepos          = 21,                            29715000
                     rtyppos           = 24,                            29720000
                     reofpos           = 37,                            29725000
                     rlimpos           = 48,                            29730000
                     rbpos             = 52,                            29735000
                     sectpos           = 61,                            29740000
                     nxpos             = 64,                            29745000
                     mxpos             = 67;                   <<u.rao>>29750000
   ARRAY             AGTITLE (0:25) = PB :=                            "29755000
ACCOUNT=              GROUP=              (CONT.) ";                    29760000
   equate            grouppos          = 15,                            29765000
                     acctpos           = 5;                             29770000
                                                                        29775000
subroutine rightnum (num, bbufdest);                                    29780000
   value bbufdest, num;                                                 29785000
   integer bbufdest, num;                                               29790000
<< right-justified number at bbuf (bbufdest) >>                         29795000
begin                                                                   29800000
   len := ascii (num, 10, tbuf);                                        29805000
   move bbuf (bbufdest -len +1) := tbuf, (len);                         29810000
   end    <<rightnum>>;                                                 29815000
subroutine rightdnum (dnum, bbufdest);                                  29820000
   value bbufdest, dnum;                                                29825000
   integer bbufdest;                                                    29830000
   double dnum;                                                         29835000
<< right-justified double at bbuf (bbufdest) >>                         29840000
begin                                                                   29845000
   len := dascii (dnum, 10, tbuf);                                      29850000
   move bbuf (bbufdest -len +1) := tbuf, (len);                         29855000
   end    <<rightdnum>>;                                                29860000
subroutine printag (length);                                            29865000
   value length;                                                        29870000
   integer length;                                                      29875000
<< print "ACCOUNT/GROUP" title >>                                       29880000
begin                                                                   29885000
   move buf := agtitle, (length);                                       29890000
   move buf (acctpos) := currenta, (4);                                 29895000
   move buf (grouppos) := currentg, (4);                                29900000
   fwrite (filenum, buf, length, 0);                                    29905000
   finishwrite +1;                                                      29910000
   end    <<printag>>;                                                  29915000
subroutine printtitle;                                                  29920000
<< prints column heading information.                                   29925000
   very simple print for now. >>                                        29930000
begin                                                                   29935000
   space;                                                               29940000
   move buf := title1, (detaillength);                                  29945000
   fwrite (filenum, buf, detaillength, 0);                              29950000
   finishwrite +1;                                                      29955000
   if detail <> 0 then                                                  29960000
      begin                                                             29965000
      move buf := title1a, (detaillength);                              29970000
      fwrite (filenum, buf, detaillength, 0);                           29975000
      finishwrite +1;                                                   29980000
      end;                                                              29985000
   space;                                                               29990000
   numperlinecount := 0;                                                29995000
   end    <<printtitle>>;                                               30000000
                                                                        30005000
                                                                        30010000
                                                                        30015000
subroutine printform1 (bufstart, length);                               30020000
   value bufstart, length;                                              30025000
   integer bufstart, length;                                            30030000
<< simply print buf (bufstart), length.  >>                             30035000
begin                                                                   30040000
   fwrite (filenum, buf (bufstart), length, 0);                         30045000
   finishwrite +1;                                                      30050000
   end    <<printform1>>;                                               30055000
subroutine printform2 (length, numberperline);                          30060000
   value length, numberperline;                                         30065000
   integer length, numberperline;                                       30070000
<< put 4 blanks at buf (length) and write it out %320,                  30075000
   unless this is last one on the line.  >>                             30080000
begin                                                                   30085000
   numperlinecount := numperlinecount -1;                               30090000
   if < then    <<1st file: initialize <numperlinecount>.>>             30095000
      numperlinecount := numberperline -1;                              30100000
   if > then                                                            30105000
      begin                                                             30110000
      buf (length) := "  ";                                             30115000
      buf (x +1) := "  ";                                               30120000
      fwrite (filenum, buf, length +2, %320);                           30125000
      finishwrite;    << <lineno> not modified >>                       30130000
      end                                                               30135000
   else                                                                 30140000
      begin                                                             30145000
      fwrite (filenum, buf, length, 0);                                 30150000
      finishwrite +1;                                                   30155000
      numperlinecount := numberperline;                                 30160000
      end;                                                              30165000
   end    <<printform2>>;                                               30170000
                                                                        30175000
subroutine printline;                                                   30180000
begin                                                                   30185000
   tos := detail & lsl(1);                                              30190000
   if devsize >= longdev then tos := tos +1;                            30195000
   case tos of                                                          30200000
      begin                                                             30205000
         printform2 (4, 6);                                             30210000
         printform2 (4, 11);                                            30215000
         printform1 (0, 25);                                            30220000
         printform2 (25, 2);                                            30225000
         printform1 (0, 34);                                   <<u.rao>>30230000
         printform1 (0,34);                                    <<u.rao>>30235000
      end;                                                              30240000
   end    <<printline>>;                                                30245000
                                                                        30250000
                                                                        30255000
subroutine formatinfo;                                                  30260000
begin                                                                   30265000
   buf := "  ";                                                         30270000
   move buf (1) := buf, (mdlwordsm1);                                   30275000
if detail >= 2 then                                                     30280000
   begin                                                                30285000
   tos := double (flblksize);          <<block factor>>                 30290000
   tos := flrecsize;                                                    30295000
   if = then tos := tos +128                                            30300000
   else if < then tos := (-tos +1) & lsr(1);                            30305000
   if flmsgfile then tos:=tos+3;  <<add in mg hdr length>>     <<01565>>30310000
   assemble (ldiv, del);                                                30315000
   rightnum ((bf := tos), rbpos);                                       30320000
   tos := @flextmap;                                                    30325000
   x := flnumexts;                                                      30330000
   tos := 0;                                                            30335000
   do begin                                                             30340000
      if dps1(x) <> 0d then tos := tos +1;                              30345000
      x := x -1;                                                        30350000
      end                                                               30355000
   until <;                                                             30360000
   rightnum ((nx := tos), nxpos);                                       30365000
   assemble (del);                                                      30370000
   rightnum(flnumexts+1, mxpos);                               <<0307>> 30375000
                                                               <<0307>> 30380000
   << compute file space in sectors.  note: last extent may >> <<0307>> 30385000
   << contain fewer sectors than the others.                >> <<0307>> 30390000
   tos := if flextmap(flnumexts) = 0d then                     <<0307>> 30395000
              logical(nx)**logical(flextsize)                  <<0307>> 30400000
          else                                                 <<0307>> 30405000
             (logical(nx)-1)**logical(flextsize) +             <<0307>> 30410000
         double(logical(fllastextsize));                                30415000
   rightdnum (*, sectpos);                                              30420000
   end;                                                                 30425000
if detail >= 1 then                                                     30430000
   begin                                                                30435000
   if flopened then bbuf(oppos) := "*";<<opened flag>>                  30440000
   if flcode < 0 then   << privileged file >>                  <<01454>>30445000
      move bbuf(codepos) := priv,(4)                           <<01454>>30450000
   else if > then   << file code > 0     >>                    <<01454>>30455000
      begin         << check for hp code >>                    <<01454>>30460000
      get'filemnemonic(flcode,bbuf(codepos),len);              <<01454>>30465000
      if <> then    << not hp mnemonic code >>                 <<01454>>30470000
         ascii(flcode,10,bbuf(codepos));                       <<01454>>30475000
      end                                                      <<01454>>30480000
   else   << file code = 0, try ksam >>                        <<01454>>30485000
      if flksam then move bbuf(codepos) := "KSAM ";            <<01454>>30490000
   tos := flrecsize;                   <<rec size>>                     30495000
   if = then tos := tos +128;                                           30500000
   if > then tos := "W"                                                 30505000
   else                                                                 30510000
      begin                                                             30515000
      tos := -tos;                                                      30520000
      if flascii then tos:="B" else                                     30525000
         begin                                                          30530000
         tos:=tos&asr(1);                                               30535000
         tos:="W";                                                      30540000
         end;                                                           30545000
      end;                                                              30550000
   if flrecformat = 1 and not flmsgfile then                   <<01549>>30555000
      begin                                                             30560000
      assemble (decb, decb);                                            30565000
      if s0 = "B" then assemble (decb, decb);                           30570000
      end;                                                              30575000
   bbuf (rsizepos) := tos;                                              30580000
   rightnum (*, x -1);                                                  30585000
   case flrecformat of                 <<rec typ>>                      30590000
      begin                                                             30595000
      tos := "F";                                                       30600000
      tos := "V";                                                       30605000
      tos := "U";                                                       30610000
                                                               <<01724>>30615000
   << undefined value (3) -- bad file label >>                 <<01724>>30620000
      begin                                                    <<01724>>30625000
      badflabel := true;                                       <<01724>>30630000
      tos := "*";                                              <<01724>>30635000
      end;                                                     <<01724>>30640000
                                                               <<01724>>30645000
      end;                                                              30650000
   bbuf (rtyppos) := tos;                                               30655000
   bbuf (rtyppos +1) := if flascii then "A" else "B";                   30660000
   if flcntrl then bbuf (rtyppos +2) := "C";                            30665000
   bbuf(rtyppos+(if flcntrl then 3 else 2)) :=                 <<01549>>30670000
      byte(filetype(flfiletype));                              <<01549>>30675000
   rightdnum (fleof, reofpos);         <<file eof>>                     30680000
   rightdnum (flflim, rlimpos);        <<file limit>>                   30685000
   end;                                                                 30690000
                                                               <<01724>>30695000
   << if bad file label, star out buffer. >>                   <<01724>>30700000
   if badflabel then                                           <<01724>>30705000
      begin                                                    <<01724>>30710000
      buf := "**";                                             <<01724>>30715000
      move buf(1) := buf,(mdlwordsm1);                         <<01724>>30720000
      end;                                                     <<01724>>30725000
                                                               <<01724>>30730000
   move buf := fname, (4);             <<filename>>                     30735000
                                                                        30740000
   end    <<formatinfo>>;                                               30745000
   if detail > 0 then                                                   30750000
      begin    <<read in file lable>>                                   30755000
      tos := finfosize;                                                 30760000
      @bflga := (@flga := (@flabel := @s0) +4) & lsl(1);                30765000
      @flextmap := @s0 +44;                                             30770000
      assemble (adds 0);                                                30775000
      tos := 0d;  <<return for attachio>>                      <<rv.pv>>30780000
      tos := lun (fpntr1.(0:8),glinkagew.(mvtabxf));           <<rv.pv>>30785000
      tos := attachio (*,0,0,@flabel,0,128,fpntr1.(8:8),fpntr2,1);      30790000
      assemble (del);                                                   30795000
      if tos.(13:3) <> 1 then                                           30800000
         begin                         <<file label i/o error>>         30805000
         tos:=sirs;                                                     30810000
         if<>then relsir(*,*);                                          30815000
         cierr(-listfflabioerr);                               <<u.rao>>30820000
         tos := 1;                                                      30825000
         goto exit;                                                     30830000
         end;                                                           30835000
      end;                                                              30840000
   tos := sirs;                                                         30845000
   if <> then relsir (*, *);                                            30850000
                                                                        30855000
   <<got all the info.  now format and print>>                          30860000
   if lineno<0 then                                            <<05.km>>30865000
      begin                                                    <<05.km>>30870000
      lineno:=-lineno;                                         <<05.km>>30875000
      firstfile:=true;                                         <<05.km>>30880000
      end;                                                     <<05.km>>30885000
   if lineno = 61 then eject;                                           30890000
   if detail>0 and firstfile then                              <<06.km>>30895000
      begin                                                             30900000
      move currentga := flga, (8);                                      30905000
      if lineno <> 1 then                                               30910000
         if lineno <= 52 then dspace                                    30915000
         else eject;                                                    30920000
      printag (20);                                                     30925000
      end                                                               30930000
   else                                                                 30935000
      begin                                                             30940000
      if lineno <> 1 then                                               30945000
         begin                                                          30950000
         if lineno <= 58 then goto printinfol;                          30955000
         eject;                                                         30960000
         end;                                                           30965000
      if detail > 0 then printag (25);                                  30970000
      end;                                                              30975000
   printtitle;                                                          30980000
printinfol:                                                             30985000
   formatinfo;                                                          30990000
    printline;                                                          30995000
   tos := 0;                                                            31000000
                                                                        31005000
exit:                                                                   31010000
   listfile := tos;                                                     31015000
   if detail > 0 then                                         <<01.02>> 31020000
     begin                                                    <<01.02>> 31025000
       dflabel(8):=0d; <<wipe out lockword>>                  <<01.02>> 31030000
       dflabel(9):=0d;                                        <<01.02>> 31035000
     end;                                                     <<01.02>> 31040000
   end    <<listfile>>;                                                 31045000
integer procedure listsavefiles (element, level, parms, sirs);          31050000
   value level, parms, sirs;                                            31055000
   integer array element;                                               31060000
   integer level, parms;                                                31065000
   double sirs;                                                         31070000
   option privileged, uncallable;                                       31075000
begin                                                                   31080000
   define p'fname=      rparms #,                              <<03.km>>31085000
          p'fname1=     rparms(1) #,                           <<03.km>>31090000
          p'ganame=     rparms(2) #,                           <<03.km>>31095000
          p'gname=      rparms(2) #,                           <<03.km>>31100000
          p'gname1=     rparms(3) #,                           <<03.km>>31105000
          p'aname=      rparms(4) #,                           <<03.km>>31110000
          p'aname1=     rparms(5) #,                           <<03.km>>31115000
          p'fpntr=      rparms(7) #,                           <<03.km>>31120000
          p'sirs=       rparms(8) #,                           <<03.km>>31125000
          p'lineno=     rparmsw(20) #,                         <<06.km>>31130000
          p'glinkagew=  rparmsw(23) #,                         <<03.km>>31135000
          p'gotentry=   rparmsw(24) #,                         <<03.km>>31140000
          p'impmntdst=  rparmsw(25) #,                         <<03.km>>31145000
          p'impmnterr=  rparmsw(26) #,                         <<03.km>>31150000
          p'impmntname= rparmsw(27) #;                         << i.a >>31155000
   define pvgroup=    logical(p'glinkagew.(pvf)) #,            <<03.km>>31160000
          releasesir=                                          <<03.km>>31165000
            begin                                              <<03.km>>31170000
            tos:=sirs;                                         <<03.km>>31175000
            if <> then relsir(*,*) else ddel;                  <<03.km>>31180000
            end #;                                             <<03.km>>31185000
   integer pvinfo'error;                                       <<10.km>>31190000
   equate nomount= 0;                                          <<03.km>>31195000
   array leafname(*)=s-6;                                      <<04.km>>31200000
   double array delement(*)=element,rparms(*);                          31205000
   integer pointer ppresult;                                  <<00.gen>>31210000
   integer array rparmsw (*) = rparms;                         <<06.km>>31215000
   equate            dirdst            = 20;                            31220000
                                                                        31225000
<<   ********************************************    >>        <<u.rao>>31230000
<<   *   a recip procedure for cxlistf          *    >>        <<u.rao>>31235000
<<   ********************************************    >>        <<u.rao>>31240000
                                                               <<u.rao>>31245000
   if requestservice then                                               31250000
      begin                                                             31255000
      listsavefiles:=abortscan'sir;                            <<03.km>>31260000
      return;                                                  <<03.km>>31265000
      end;                                                              31270000
   tos:=delement;                                             <<00.gen>>31275000
   tos:=delement(1);                                          <<00.gen>>31280000
   tos:=delement(2);                                          <<01.gen>>31285000
   tos:=element(glinkage);                                    <<00.gen>>31290000
   exchangedb(0);                                             <<00.gen>>31295000
   @rparms:=@arrq0(parms-deltaq);                             <<00.gen>>31300000
                                                              <<00.gen>>31305000
   @ppresult:=@rparms+sysl'pprinx;                            <<00.gen>>31310000
   if logical(d'type.(allflag)) then                          <<00.gen>>31315000
   begin                                                      <<00.gen>>31320000
     comment:                                                 <<00.gen>>31325000
       (s-6,s-3) = leaf name                                   <<04.km>>31330000
       (s-2,s-0) = misc entry info;                            <<04.km>>31335000
                                                              <<00.gen>>31340000
     case *level of begin                                     <<00.gen>>31345000
       tos:=dirmatch(g'fname,leafname);                       <<00.gen>>31350000
       tos:=dirmatch(g'gname,leafname);                       <<00.gen>>31355000
       tos:=dirmatch(g'aname,leafname);                       <<00.gen>>31360000
       tos:=-1;                        <<shouldn't happen>>    <<03.km>>31365000
       tos:=-1;                        <<shouldn't happen>>    <<03.km>>31370000
     end;                                                     <<00.gen>>31375000
     if tos<>0 then                                           <<00.gen>>31380000
     begin                                                    <<00.gen>>31385000
       listsavefiles:=if < then nextuncle'sir                  <<03.km>>31390000
                      else nextbrother'sir;                    <<03.km>>31395000
       exchangedb(dirdst);                                     <<03.km>>31400000
       return;                                                 <<03.km>>31405000
     end;                                                     <<00.gen>>31410000
   end;                                                       <<00.gen>>31415000
                                                              <<00.gen>>31420000
   case *level of                                              <<04.km>>31425000
     begin                                                     <<04.km>>31430000
     comment:                                                  <<04.km>>31435000
       (s-6,s-3)= leaf name                                    <<04.km>>31440000
       (s-2,s-1)= fpntr (valid iff file level)                 <<04.km>>31445000
       s-0=       glinkagew (valid iff group level).           <<04.km>>31450000
                                                               <<04.km>>31455000
       each case leaves "LISTSAVEFILES" value on tos;          <<04.km>>31460000
                                                               <<04.km>>31465000
     <<0>> begin <<file>>                                      <<04.km>>31470000
           del;                                                <<04.km>>31475000
           p'fpntr:=tos;                                       <<04.km>>31480000
           p'fname1:=tos;                                      <<04.km>>31485000
           p'fname:=tos;                                       <<04.km>>31490000
           p'sirs:=sirs;                                       <<04.km>>31495000
           p'gotentry:=true;                                   <<04.km>>31500000
           if listfile(rparms)<=1 then tos:=nextson            <<04.km>>31505000
           else                                                <<04.km>>31510000
             begin                                             <<04.km>>31515000
             rparmsw(1):=-1;                                   <<04.km>>31520000
             tos:=abortscan;                                   <<04.km>>31525000
             end;                                              <<04.km>>31530000
           end;                                                <<04.km>>31535000
                                                               <<04.km>>31540000
     <<1>> begin <<group>>                                     <<04.km>>31545000
           p'glinkagew:=tos;                                   <<04.km>>31550000
           ddel;                                               <<04.km>>31555000
           p'gname1:=tos;                                      <<04.km>>31560000
           p'gname:=tos;                                       <<04.km>>31565000
           if p'lineno>0 then p'lineno:=-p'lineno;             <<10.km>>31570000
           releasesir;                                         <<04.km>>31575000
           if not pvgroup then tos:=nextson                    <<04.km>>31580000
           else if implicitmnt(p'gname,p'aname,p'impmntdst,    <<04.km>>31585000
                               pvinfo'error) then              <<10.km>>31590000
             begin                                             <<04.km>>31595000
             p'glinkagew.(mvtabxf):=pvinfo'error.(pvmvtabxf);  <<10.km>>31600000
             tos:=revisit;                                     <<04.km>>31605000
             end                                               <<04.km>>31610000
           else if pvinfo'error=nomount then                   <<10.km>>31615000
             begin                                             <<04.km>>31620000
             p'impmnterr:=pvinfo'error;                        <<10.km>>31625000
             tos:=revisit;             <<dds used by "MOUNT">> <<05.km>>31630000
             end                                               <<04.km>>31635000
           else                                                <<04.km>>31640000
             begin                                             <<04.km>>31645000
             p'impmnterr:=pvinfo'error;                        <<10.km>>31650000
             move p'impmntname:=p'ganame,(8);                  <<04.km>>31655000
             tos:=abortscan;                                   <<04.km>>31660000
             end;                                              <<04.km>>31665000
           end;                                                <<04.km>>31670000
                                                               <<04.km>>31675000
     <<2>> begin <<account>>                                   <<04.km>>31680000
           del;                                                <<04.km>>31685000
           ddel;                                               <<04.km>>31690000
           p'aname1:=tos;                                      <<04.km>>31695000
           p'aname:=tos;                                       <<04.km>>31700000
           tos:=nextson'sir;                                   <<04.km>>31705000
           end;                                                <<04.km>>31710000
                                                               <<05.km>>31715000
     <<3>> tos:=abortscan'sir;         <<shouldn't happen>>    <<10.km>>31720000
     <<4>> tos:=abortscan'sir;         <<shouldn't happen>>    <<10.km>>31725000
     end <<case>>;                                             <<04.km>>31730000
   exchangedb(dirdst);                                         <<04.km>>31735000
   listsavefiles:=tos;                                         <<04.km>>31740000
   end;                                                                 31745000
                                                              <<00.gen>>31750000
                                                              <<00.gen>>31755000
procedure getdirinfo(startinx,deflevel,ppresult);             <<00.gen>>31760000
                    value startinx,deflevel;                  <<00.gen>>31765000
                    integer startinx,                         <<00.gen>>31770000
                            deflevel;                         <<00.gen>>31775000
                    integer array ppresult;                   <<00.gen>>31780000
                    option privileged,uncallable;              <<01.km>>31785000
begin                                                         <<00.gen>>31790000
  comment:                                                    <<00.gen>>31795000
    acquires the group or account index and log-on            <<00.gen>>31800000
    group and account names from the jit.  these              <<00.gen>>31805000
    are stored into "D'INX", "G'GNAME" and "G'ANAME"          <<00.gen>>31810000
    of "PPRESULT";                                            <<00.gen>>31815000
                                                              <<00.gen>>31820000
integer array jitarr(0:jit'entry'size-1);                      <<06840>>31825000
  equate  pxglob= -1;                                          <<06840>>31830000
  array qarray(*)=q+0;                                         <<06567>>31835000
  integer pcbglobloc;                                          <<06567>>31840000
  double array dppresult(*)=ppresult;                         <<00.gen>>31845000
  integer jit'dst;                                             <<06840>>31850000
  switch default:= nodefault,adefault,gdefault;               <<00.gen>>31855000
                                                              <<00.gen>>31860000
  subroutine def'movefromdseg;                                <<00.gen>>31865000
                                                              <<00.gen>>31870000
                                                              <<00.gen>>31875000
                                                              <<00.gen>>31880000
  pxglobal;                                                    <<06567>>31885000
  jit'dst:=pxg'jitdst;                                         <<06840>>31890000
  tos:=@jitarr;                                                <<06840>>31895000
  tos:=jit'dst;                                                <<06840>>31900000
  tos:=0;                                                      <<06840>>31905000
  tos:=jit'entry'size;                                         <<06840>>31910000
  assemble(mfds 4);                                            <<06840>>31915000
  case *startinx of begin                                     <<00.gen>>31920000
    <<0>> d'inx:=0d;                                          <<00.gen>>31925000
          << get account index pointers if first case       >> <<06840>>31930000
    <<1>> move d'inx:=jitaip,(2);                              <<06840>>31935000
    <<2>> begin                                                <<06840>>31940000
            << if mounted pv, then get group index pointers >> <<06840>>31945000
            << to that pv, else get group index pointers to >> <<06840>>31950000
            << the group on system domain                   >> <<06840>>31955000
            if jitgimvf = 1                                    <<06840>>31960000
               then move d'inx:=jitpvgip,(2)                   <<06840>>31965000
               else move d'inx:=jitgip,(2);                    <<06840>>31970000
            d'inx1.(pvf):=jitgipvf;                            <<06840>>31975000
          end;                                                <<00.gen>>31980000
  end;                                                        <<00.gen>>31985000
  goto *default(deflevel);                                    <<00.gen>>31990000
                                                              <<00.gen>>31995000
gdefault:                                                     <<00.gen>>32000000
  move g'gname:=jitlogongroup,(4);                             <<06840>>32005000
  move d'gname := g'gname, (4);                                <<07275>>32010000
                                                              <<00.gen>>32015000
adefault:                                                     <<00.gen>>32020000
  move g'aname:=jithacctname,(4);                              <<06840>>32025000
  move d'aname := g'aname, (4);                                <<07275>>32030000
                                                              <<00.gen>>32035000
nodefault:                                                    <<00.gen>>32040000
                                                              <<00.gen>>32045000
end <<procedure getdirinfo>>;                                 <<00.gen>>32050000
                                                              <<00.gen>>32055000
                                                              <<00.gen>>32060000
integer procedure getgenname(qname,errbase,leafname,namefound,<<01.gen>>32065000
                             generic);                        <<01.gen>>32070000
                            value errbase,leafname,generic;   <<01.gen>>32075000
                            byte pointer qname;               <<00.gen>>32080000
                            integer errbase;                  <<00.gen>>32085000
                            byte pointer leafname;            <<00.gen>>32090000
                            logical namefound;                <<01.gen>>32095000
                            integer pointer generic;          <<01.gen>>32100000
                            option variable,uncallable;       <<00.gen>>32105000
begin                                                         <<00.gen>>32110000
  comment:                                                    <<00.gen>>32115000
    scan "QNAME" for directory name, viz:  up to 8 alpha-     <<00.gen>>32120000
    numeric characters starting with alphabetic, delimited by <<00.gen>>32125000
    special (ultimately a 'cr').  if error is detected,       <<00.gen>>32130000
    offset is added to "ERRBASE" to determine error code.     <<00.gen>>32135000
    "GETGENNAME" returns the error code (>0) or a no-error    <<00.gen>>32140000
    indication (=0).  routine moves directory name into       <<00.gen>>32145000
    "LEAFNAME" and, in "QNAME", returns pointer to delimiter. <<00.gen>>32150000
    "GENERIC" is nonzero if directory name contained "@",     <<00.gen>>32155000
    "?" or "#".                                               <<00.gen>>32160000
                                                              <<00.gen>>32165000
    note that "@@" and "@?" are ambiguous.  these are auto-   <<00.gen>>32170000
    matically corrected to "@" and "?@".  (on the other hand, <<00.gen>>32175000
    "@#" is meaningful and is not equivalent to "#@".)        <<00.gen>>32180000
                                                              <<00.gen>>32185000
    on entry, "NAMEFOUND" indicates whether a leafname        <<01.gen>>32190000
    had been found previously.  on exit, "NAMEFOUND" is       <<01.gen>>32195000
    true if leafname was found.  if no leafname is found      <<01.gen>>32200000
    and "NAMEFOUND" was true on entry, then we flag an        <<01.gen>>32205000
    error.                                                    <<01.gen>>32210000
                                                              <<01.gen>>32215000
    note that we assume that traps are off on entry.  also    <<00.gen>>32220000
    note that name is upshifted in "QNAME" itself.  caller    <<00.gen>>32225000
    should blank-fill "LEAFNAME" before call;                 <<00.gen>>32230000
                                                               <<01.km>>32235000
  label exitinstr;                                             <<01.km>>32240000
  define exitproc= assemble(br *+1,i; con exitinstr) #;        <<01.km>>32245000
                                                              <<00.gen>>32250000
  define skipwildcard=                                        <<00.gen>>32255000
           begin                                              <<00.gen>>32260000
             bps1:=bps0;               <<move "?" or "@">>    <<00.gen>>32265000
             assemble(incb,inca);      <<and skip it    >>    <<00.gen>>32270000
             generic:=generic+1;                              <<00.gen>>32275000
           end #,                                             <<00.gen>>32280000
         skipall'at=                                          <<00.gen>>32285000
           begin                                              <<00.gen>>32290000
             bps1:="@";                <<move "@" and   >>    <<00.gen>>32295000
             generic:=generic+1;       <<skip subsequent>>    <<00.gen>>32300000
             ignoreall'at;                                    <<00.gen>>32305000
           end #,                                             <<00.gen>>32310000
         ignoreall'at=                                        <<00.gen>>32315000
           begin                                              <<00.gen>>32320000
             assemble(incb,inca);                             <<00.gen>>32325000
             scan * while cr'at,1;                            <<00.gen>>32330000
           end #,                                              <<00608>>32335000
         ignore'wildcard=                                      <<00608>>32340000
           begin                                               <<00608>>32345000
             assemble(incb,inca);                              <<00608>>32350000
           end #;                                              <<00608>>32355000
                                                              <<00.gen>>32360000
  define nogeneric= not parmmask #;                           <<01.gen>>32365000
                                                              <<00.gen>>32370000
  equate expectalpha=  fileexpectalpha-ffnamebase,            <<00.gen>>32375000
         namemissing=  filenamemissing-ffnamebase,            <<00.gen>>32380000
         nametoolong=  filenametoolong-ffnamebase,            <<00.gen>>32385000
         missingdelim= filemissingdelim-ffnamebase,           <<00.gen>>32390000
         nogenname=    filenogenname-ffnamebase;              <<00.gen>>32395000
                                                              <<00.gen>>32400000
  equate cr=%15,                                              <<00.gen>>32405000
         crblank= [8/cr,8/" "],                               <<00.gen>>32410000
         cr'at=   [8/cr,8/"@"];                               <<00.gen>>32415000
                                                              <<00.gen>>32420000
  byte pointer bps0=s-0,                                      <<00.gen>>32425000
               bps1=s-1,                                      <<00.gen>>32430000
               buf,                                            <<00608>>32435000
               delim:=@qname;                                 <<00.gen>>32440000
  integer dumgen,                                             <<00.gen>>32445000
          length;                                             <<01.gen>>32450000
  logical parmmask=q-4;                                       <<00.gen>>32455000
                                                              <<00.gen>>32460000
                                                              <<00.gen>>32465000
  subroutine error(offset); value offset; integer offset;     <<00.gen>>32470000
  begin                                                       <<00.gen>>32475000
    cierr((getgenname:=errbase+offset),qname);                <<00.gen>>32480000
    @qname:=@delim;                                           <<00.gen>>32485000
    exitproc;                                                  <<01.km>>32490000
  end <<subroutine error>>;                                   <<00.gen>>32495000
                                                              <<00.gen>>32500000
                                                              <<00.gen>>32505000
  getgenname:=0;                                              <<00.gen>>32510000
  if nogeneric then @generic:=@dumgen;                        <<00.gen>>32515000
  scan qname while crblank,1;          <<skip lead blanks>>   <<00.gen>>32520000
  @qname:=tos;                                                <<00.gen>>32525000
  if > then error(expectalpha);                               <<00.gen>>32530000
  if qname="#" then error(if nogeneric then nogenname         <<00.gen>>32535000
                          else expectalpha);                  <<00.gen>>32540000
                                                              <<00.gen>>32545000
  generic:=0;                                                 <<00.gen>>32550000
  tos:=tos:=@qname;                    <<find len of name>>    <<00608>>32555000
  do begin                                                     <<00608>>32560000
    move * := * while ans,0;                                   <<00608>>32565000
    while bps0="?" or bps0="#" or bps0="@" do                  <<00608>>32570000
      ignore'wildcard;                                         <<00608>>32575000
  end until bps0=special;                                      <<00608>>32580000
  @delim := tos;                                               <<00608>>32585000
  length := tos-@qname;                                        <<00608>>32590000
  comment:                                                     <<00608>>32595000
    allocate space for buf & use buf as a work-                <<00608>>32600000
    space as we may                                            <<00608>>32605000
      1) need to modify the name in qname                      <<00608>>32610000
      2) find that the name is longer than 8                   <<00608>>32615000
         char. (ie too long for leafname)                      <<00608>>32620000
    buf must be able to hold 'length' bytes of data            <<00608>>32625000
    plus a cr.;                                                <<00608>>32630000
  tos := (length+2)/2;                 <<# of words in buf>>   <<00608>>32635000
  @buf := @s0 & lsl(1);                                        <<00608>>32640000
  assemble(adds 0);                                            <<00608>>32645000
  buf(length) := cr;                                           <<00608>>32650000
  move buf := qname,(length);                                  <<00608>>32655000
                                                               <<00608>>32660000
  tos:=tos:=@buf;                      <<scan generic name>>   <<00608>>32665000
  do begin                                                    <<00.gen>>32670000
    move * := * while ans,0;                                  <<00.gen>>32675000
    while bps0="?" or bps0="#" do skipwildcard;               <<00.gen>>32680000
    if bps0="@" then                                          <<00.gen>>32685000
    begin                                                     <<00.gen>>32690000
      skipall'at;                      <<"@...@" ==> "@">>    <<00.gen>>32695000
      while bps0="?" do                <<"@?...?" ==> >>      <<00.gen>>32700000
      begin                            <<"?...?@"     >>      <<00.gen>>32705000
        bps1(-1):="?";                                        <<00.gen>>32710000
        bps1:="@";                                            <<00.gen>>32715000
        ignoreall'at;                  <<"@...@" ==> "@">>    <<00.gen>>32720000
      end;                                                    <<00.gen>>32725000
    end;                                                      <<00.gen>>32730000
  end until bps0=special and bps0<>"#";                       <<00.gen>>32735000
  del;                                                         <<00608>>32740000
  length:=tos-@buf;                                            <<00608>>32745000
                                                              <<00.gen>>32750000
  if <> then namefound:=true                                  <<01.gen>>32755000
  else if namefound then error(namemissing);                  <<01.gen>>32760000
  if generic>0 and nogeneric then error(nogenname);           <<00.gen>>32765000
  if length>8 then error(nametoolong);                        <<00.gen>>32770000
  move leafname:=buf,(length);                                 <<00608>>32775000
  scan delim while crblank,1;          <<skip trail blanks>>  <<00.gen>>32780000
  @qname:=tos;                                                <<00.gen>>32785000
  if >= then error(missingdelim);      <<alphanumeric>>       <<00.gen>>32790000
                                                               <<01.km>>32795000
exitinstr:                                                     <<01.km>>32800000
end <<procedure getgenname>>;                                 <<00.gen>>32805000
                                                              <<00.gen>>32810000
                                                              <<00.gen>>32815000
logical procedure produceparms(leaflevel,qname,ppresult,      <<00.gen>>32820000
                               delim,errnum);                 <<00.gen>>32825000
                              value leaflevel,qname;          <<00.gen>>32830000
                              integer leaflevel;              <<00.gen>>32835000
                              byte pointer qname;             <<00.gen>>32840000
                              array ppresult;                 <<00.gen>>32845000
                              byte pointer delim;             <<00.gen>>32850000
                              integer errnum;                 <<00.gen>>32855000
                              option privileged,uncallable;   <<00.gen>>32860000
begin                                                         <<00.gen>>32865000
  comment:                                                    <<00.gen>>32870000
    parses fully-qualified "LEAFLEVEL" name in "QNAME" and    <<00.gen>>32875000
    sets up direcscan parameters in "PPRESULT".  returns      <<00.gen>>32880000
    final delimiter in "DELIM".  names in "QNAME" may contain <<00.gen>>32885000
    blanks around delimiters.  if no name is present, we       <<01.km>>32890000
    return one of the following defaults:                      <<01.km>>32895000
                                                              <<05.gen>>32900000
    leaflevel = 0, file f[.g[.a]]:  @.lgn.lan                 <<05.gen>>32905000
     (input)    1, group g[.a]:  @.lan                        <<05.gen>>32910000
                2, account a:  @                              <<05.gen>>32915000
                3, user u[.a]:  @.lan                         <<05.gen>>32920000
                4, vol set defn v[.g[.a]]:  @.lgn.lan         <<05.gen>>32925000
                                                              <<00.gen>>32930000
    other outputs are:                                        <<05.gen>>32935000
                                                              <<05.gen>>32940000
    startlevel = 0: global search for f.g.a, v.g.a, u[.a], a  <<00.gen>>32945000
     (output)    1: use acct inx ptr for f.g, v[.g]           <<05.gen>>32950000
                 2: use group inx ptr for f                   <<00.gen>>32955000
                                                              <<00.gen>>32960000
    endlevel = 0: f[.g[.a]], @[.g[.a]]                        <<00.gen>>32965000
    (output)   1: g[.a], @[.a]                                <<05.gen>>32970000
               2: @.@.@, a                                    <<00.gen>>32975000
               3: u[.a], @[.a]                                <<00.gen>>32980000
               4: v[.g[.a]], @[.g[.a]]                        <<00.gen>>32985000
                                                              <<00.gen>>32990000
    result is returned in "PPRESULT" in the form:             <<00.gen>>32995000
                                                              <<00.gen>>33000000
      ********************                                    <<00.gen>>33005000
      * d'inx      (2wd) * 0                                  <<00.gen>>33010000
      *------------------*                                    <<00.gen>>33015000
      * d'type     (1wd) * 2                                  <<00.gen>>33020000
      *------------------*                                    <<00.gen>>33025000
      * d'fname    (4wd) * 3   "D'XXX" contain the names used <<00.gen>>33030000
      * d'vname          *     for the directory search.  the <<00.gen>>33035000
      *------------------*     names must be in one of the    <<00.gen>>33040000
      * d'gname    (4wd) * 7   following forms:               <<00.gen>>33045000
      * d'uname          *       f.g.a     @.@.a              <<00.gen>>33050000
      *------------------*       @.g.a     @.@.@              <<00.gen>>33055000
      * d'aname    (4wd) * 11                                 <<00.gen>>33060000
      *                  *                                    <<00.gen>>33065000
      *------------------*                                    <<00.gen>>33070000
      * d'lockword (4wd) * 15                                 <<00.gen>>33075000
      *                  *                                    <<00.gen>>33080000
      *------------------*                                    <<00.gen>>33085000
      * g'fname    (4wd) * 19  "G'XXX" contain the generic    <<00.gen>>33090000
      * g'vname          *     names actually specified.      <<00.gen>>33095000
      *------------------*     these are used by the "RECIP"  <<00.gen>>33100000
      * g'gname    (4wd) * 23  procedure to determine a match <<00.gen>>33105000
      * g'uname          *     during the directory search.   <<00.gen>>33110000
      *------------------*                                    <<00.gen>>33115000
      * g'aname    (4wd) * 27                                 <<00.gen>>33120000
      *                  *                                    <<00.gen>>33125000
      ********************                                    <<00.gen>>33130000
    ;                                                         <<00.gen>>33135000
                                                               <<01.km>>33140000
  label exitinstr;                                             <<01.km>>33145000
  define exitproc= assemble(br *+1,i; con exitinstr) #;        <<01.km>>33150000
                                                              <<00.gen>>33155000
  define turnofftraps=                                        <<00.gen>>33160000
           begin                                              <<00.gen>>33165000
             push(status);                                    <<00.gen>>33170000
             tos.(2:1):=0;                                    <<00.gen>>33175000
             set(status);                                     <<00.gen>>33180000
           end #;                                             <<00.gen>>33185000
  define namemissing= errbase+filenamemissing-ffnamebase #;   <<05.gen>>33190000
  equate noinx=    0,                                         <<00.gen>>33195000
         acctinx=  1,                                         <<00.gen>>33200000
         groupinx= 2;                                         <<00.gen>>33205000
  integer array initparms(*)=pb:=                             <<02.gen>>33210000
    3(0),3("@       "),4("  "),3("@       ");                 <<05.gen>>33215000
  integer array initstart(*)=pb:=                             <<00.gen>>33220000
    groupinx,acctinx,noinx,noinx,acctinx;                     <<00.gen>>33225000
  integer array initdef(*)=pb:=                               <<00.gen>>33230000
    groupinx,acctinx,noinx,acctinx,groupinx;                  <<00.gen>>33235000
  integer array initbase(*)=pb:=                              <<00.gen>>33240000
    ffnamebase,fgnamebase,fanamebase,usernamebase,vsdnamebase;<<00.gen>>33245000
  integer array initall(*)=pb:= 1,2,3,2,1;                    <<03.gen>>33250000
                                                              <<00.gen>>33255000
  integer startinx,                                           <<00.gen>>33260000
          deflevel,                                           <<00.gen>>33265000
          errbase,                                            <<00.gen>>33270000
          generic,                                            <<00.gen>>33275000
          alllevel:= 0;                                       <<05.gen>>33280000
  logical namefound:=false;                                   <<01.gen>>33285000
  switch parser:= files,groups,accounts,users,vsds;           <<00.gen>>33290000
                                                              <<00.gen>>33295000
                                                              <<00.gen>>33300000
  subroutine error(msgnum); value msgnum; integer msgnum;     <<00.gen>>33305000
  begin                                                       <<00.gen>>33310000
    cierr((errnum:=msgnum),qname);                            <<00.gen>>33315000
    exitproc;                                                  <<01.km>>33320000
  end <<subroutine error>>;                                   <<00.gen>>33325000
                                                              <<00.gen>>33330000
                                                              <<00.gen>>33335000
  produceparms:=false;                                        <<00.gen>>33340000
  turnofftraps;                        <<for byte adr arith>> <<00.gen>>33345000
  move ppresult:=initparms,(31);       <<f.g.a="@.@.@">>      <<02.gen>>33350000
  startinx:=initstart(leaflevel);                             <<05.gen>>33355000
  deflevel:=initdef(leaflevel);                               <<05.gen>>33360000
  errbase:=initbase(leaflevel);                               <<00.gen>>33365000
  goto *parser(leaflevel);                                    <<00.gen>>33370000
                                                              <<00.gen>>33375000
  <<**********************>>                                  <<00.gen>>33380000
  << parse qualified name >>                                  <<00.gen>>33385000
  <<**********************>>                                  <<00.gen>>33390000
                                                              <<00.gen>>33395000
files:                                                        <<00.gen>>33400000
vsds:                                                         <<00.gen>>33405000
  if (errnum:=getgenname(qname,errbase,g'fname,namefound,     <<01.gen>>33410000
                         generic))<>0                         <<01.gen>>33415000
     then return;                                             <<00.gen>>33420000
  if generic>0 then alllevel:=1;                              <<00.gen>>33425000
  if qname="/" then                                           <<00.gen>>33430000
  begin                                                       <<00.gen>>33435000
    if leaflevel=vsdeflevel then error(vsdnolockword);        <<00.gen>>33440000
    if not namefound then error(namemissing);                 <<04.gen>>33445000
    @qname:=@qname+1;                                         <<00.gen>>33450000
    if (errnum:=getgenname(qname,flwordbase,d'lockword,       <<02.gen>>33455000
                           namefound))<>0                     <<02.gen>>33460000
       then return;                                           <<00.gen>>33465000
  end;                                                        <<00.gen>>33470000
  if not namefound or qname<>"." then go completeparms;       <<04.gen>>33475000
  @qname:=@qname+1;                                           <<00.gen>>33480000
  errbase:=fgnamebase;                                        <<00.gen>>33485000
  startinx:=deflevel:=acctinx;                                <<00.gen>>33490000
                                                              <<00.gen>>33495000
groups:                                                       <<00.gen>>33500000
users:                                                        <<00.gen>>33505000
  if (errnum:=getgenname(qname,errbase,g'gname,namefound,     <<02.gen>>33510000
                         generic))<>0                         <<01.gen>>33515000
     then return;                                             <<00.gen>>33520000
  if generic>0 then alllevel:=2;                              <<00.gen>>33525000
  if not namefound or qname<>"." then go completeparms;       <<01.gen>>33530000
  @qname:=@qname+1;                                           <<00.gen>>33535000
  errbase:=fanamebase;                                        <<00.gen>>33540000
  startinx:=deflevel:=noinx;                                  <<00.gen>>33545000
                                                              <<00.gen>>33550000
accounts:                                                     <<00.gen>>33555000
  if (errnum:=getgenname(qname,errbase,g'aname,namefound,     <<02.gen>>33560000
                         generic))<>0                         <<01.gen>>33565000
     then return;                                             <<00.gen>>33570000
  if generic>0 then alllevel:=3;                              <<00.gen>>33575000
                                                              <<00.gen>>33580000
completeparms:                                                <<00.gen>>33585000
  if not namefound then                                       <<04.gen>>33590000
  begin                                                       <<04.gen>>33595000
    if qname="." then error(namemissing);                     <<04.gen>>33600000
    alllevel:=initall(leaflevel);                             <<04.gen>>33605000
  end;                                                        <<04.gen>>33610000
  @delim:=@qname;                                             <<00.gen>>33615000
  d'type.(startlevelf):=startinx;                             <<00.gen>>33620000
  d'type.(tolevelf):=leaflevel;                               <<00.gen>>33625000
                                                              <<00.gen>>33630000
  <<***************************>>                             <<00.gen>>33635000
  << set up group/acct index & >>                             <<00.gen>>33640000
  << default group/acct names  >>                             <<00.gen>>33645000
  <<***************************>>                             <<00.gen>>33650000
                                                              <<00.gen>>33655000
  if startinx<>noinx or deflevel<>noinx then                  <<00.gen>>33660000
  begin                                                       <<00.gen>>33665000
    getdirinfo(startinx,deflevel,ppresult);                   <<00.gen>>33670000
  end;                                                        <<00.gen>>33675000
                                                              <<00.gen>>33680000
  <<*****************>>                                       <<00.gen>>33685000
  << set up endlevel >>                                       <<00.gen>>33690000
  <<*****************>>                                       <<00.gen>>33695000
                                                              <<00.gen>>33700000
  case *alllevel of begin              <<set endlevelfx>>     <<00.gen>>33705000
    <<0>> begin                                               <<00.gen>>33710000
            move d'fname:=g'fname,(12);                       <<00.gen>>33715000
            d'type.(endlevelfx):=leaflevel;                   <<00.gen>>33720000
          end;                                                <<00.gen>>33725000
    <<1>> begin                                               <<00.gen>>33730000
            move d'gname:=g'gname,(8);                        <<00.gen>>33735000
            d'type.(endlevelfx):=allxxx+leaflevel;            <<00.gen>>33740000
          end;                                                <<00.gen>>33745000
    <<2>> begin                                               <<00.gen>>33750000
            move d'aname:=g'aname,(4);                        <<00.gen>>33755000
            d'type.(endlevelfx):=                             <<00.gen>>33760000
              if leaflevel=userlevel then allusers            <<00.gen>>33765000
              else allgroups;                                 <<00.gen>>33770000
          end;                                                <<00.gen>>33775000
    <<3>> d'type.(endlevelfx):=allaccts;                      <<00.gen>>33780000
  end;                                                        <<00.gen>>33785000
  produceparms:=true;                                         <<01.gen>>33790000
                                                               <<01.km>>33795000
exitinstr:                                                     <<01.km>>33800000
end  <<procedure produceparms>>;                              <<00.gen>>33805000
                                                              <<00.gen>>33810000
                                                              <<00.gen>>33815000
procedure cxlistf executorhead;                                <<u.rao>>33820000
option privileged, uncallable;                                 <<u.rao>>33825000
begin                                                          <<u.rao>>33830000
$include inclcap                                               <<06567>>33835000
                                                               <<03.km>>33840000
define p'ganame=     recipparms(4) #,                          <<04.km>>33845000
       p'gotentry=   recipparms(24) #,                         <<03.km>>33850000
       p'impmntdst=  recipparms(25) #,                         <<03.km>>33855000
       p'impmnterr=  recipparms(26) #,                         <<03.km>>33860000
       p'impmntgrp=  recipparms(27) #,                         <<03.km>>33865000
       p'impmntacct= recipparms(31) #;                         <<03.km>>33870000
define pageeject = fwrite(fnum,datebuf,0,%61) #;               <<09.mm>>33875000
equate nomnterr= -1,                                           <<03.km>>33880000
       nomount=  0;                                            <<03.km>>33885000
equate f'stdlist      = 1,                                     <<00852>>33890000
       new'file       = 0,                                     <<00852>>33895000
       temp'domain    = 2,                                     <<00852>>33900000
       current'domain = 0;                                     <<00852>>33905000
double dl := commasemicr;                                      <<u.rao>>33910000
integer numparms;                                              <<u.rao>>33915000
double array parms(0:3)=q;                                     <<u.rao>>33920000
integer array recipparms(0:sysl'parmlen-1);                   <<00.gen>>33925000
integer array ppresult(*)=recipparms(sysl'pprinx);            <<00.gen>>33930000
byte pointer leafname = parms;                                 <<u.rao>>33935000
integer leafnamechar = parms+1;                                <<u.rao>>33940000
byte leafnamelen = parms+1;                                    <<u.rao>>33945000
byte pointer listlevel = parms+2;                              <<u.rao>>33950000
byte listlevellen = parms+3;                                   <<u.rao>>33955000
byte pointer listfile = parms+2;  <<tricky bit>>               <<u.rao>>33960000
integer listfilechar = parms+3;                                <<u.rao>>33965000
byte pointer extraparm = parms+6;                              <<u.rao>>33970000
byte extraparmlen = parms+7;                                   <<u.rao>>33975000
equate comma = 0, semi = 1, cr = 2;                            <<u.rao>>33980000
byte pointer delim;                                           <<00.gen>>33985000
integer foptions := %2504;                                     <<u.rao>>33990000
integer fclose'foptions := 0;                                  <<00852>>33995000
logical stdlist := true;                                       <<u.rao>>34000000
integer fnum := 2;  <<default to $stdlist>>                    <<u.rao>>34005000
array datebuf(0:13);  <<used for time stamp of output>>        <<02.ro>>34010000
integer dev := 0;  <<device type of list file>>                <<03.ro>>34015000
array qarray(*)=q+0;                                           <<06567>>34020000
integer pcbglobloc;                                            <<06567>>34025000
pointer ucapptr;                                               <<06567>>34030000
logical interactive;                                           <<09.mm>>34035000
                                                               <<u.rao>>34040000
<<initialize parms array>>                                     <<u.rao>>34045000
parms := 0d;                                                   <<u.rao>>34050000
tos := @parms+2;                                               <<u.rao>>34055000
tos := @parms+1;                                               <<u.rao>>34060000
tos := 6;                                                      <<u.rao>>34065000
assemble(move);                                                <<u.rao>>34070000
mycommand(parmsp,dl,4,numparms,parms);                         <<u.rao>>34075000
parmnum := 1;                                                  <<u.rao>>34080000
if not produceparms(0,parmsp,ppresult,delim,errnum) then      <<00.gen>>34085000
    return;  <<error in parsing leafname>>                     <<u.rao>>34090000
if (numparms > 0) and  <<not just a cr>>                       <<u.rao>>34095000
   (@delim < @leafname+integer(leafnamelen)) then             <<00.gen>>34100000
   begin  <<extraneous stuff in leafname>>                     <<u.rao>>34105000
   tos := errnum := listfextraneous;                           <<u.rao>>34110000
   tos := @delim;                                             <<00.gen>>34115000
   cierr(*,*);                                                 <<u.rao>>34120000
   return                                                      <<u.rao>>34125000
   end;                                                        <<u.rao>>34130000
                                                               <<u.rao>>34135000
if numparms=0 then leafnamechar := cr;                         <<u.rao>>34140000
                                                               <<u.rao>>34145000
<<check for listlevel, if any>>                                <<u.rao>>34150000
if leafnamechar.(11:5)=comma then  <<listlevel present>>       <<u.rao>>34155000
   begin                                                       <<u.rao>>34160000
   parmnum := 2;                                               <<u.rao>>34165000
   tos := binary(listlevel,integer(listlevellen));             <<u.rao>>34170000
   if <> or not(-1 <= s0 <= 2) then                            <<u.rao>>34175000
      begin   <<bad conversion or bad number>>                 <<u.rao>>34180000
      cierr(errnum := -listfbadlevel, listlevel);              <<04785>>34185000
      if tos < -1 then    <<give listf,-1>>                    <<u.rao>>34190000
         tos := -1                                             <<u.rao>>34195000
      else                <<give listf,2>>                     <<u.rao>>34200000
         tos := 2;                                             <<u.rao>>34205000
      end;                                                     <<u.rao>>34210000
   if s0 > 2 then tos := 2;  <<max level>>                     <<u.rao>>34215000
   if s0 < 0 then  <<listf -1 case?>>                          <<u.rao>>34220000
      begin  <<check capability>>                              <<u.rao>>34225000
      if d'type.(startlevelf) = 0 then  <<system level file>> <<00.gen>>34230000
         begin                                                 <<u.rao>>34235000
         pxglobal;                                             <<06567>>34240000
         @ucapptr := @pxg'userattributes;                      <<06567>>34245000
         if not ucapsm and                                     <<06567>>34250000
            not (ucapam land checkhomeacct(ppresult)=0) then   <<06567>>34255000
            begin << not (smcap or amcap and homeacct =     >> <<00450>>34260000
                  <<                         requestedacct) >> <<00450>>34265000
            if checkhomeacct(ppresult)=0 then                  <<00450>>34270000
               cierr(errnum := listfamcap)                     <<00450>>34275000
            else cierr(errnum := listfsmcap);                  <<00450>>34280000
            return                                             <<u.rao>>34285000
            end;                                               <<u.rao>>34290000
         end                                                   <<u.rao>>34295000
      else   <<check for account manager capability>>          <<04.ro>>34300000
         begin                                                 <<04.ro>>34305000
         pxglobal;                                             <<06567>>34310000
         @ucapptr := @pxg'userattributes;                      <<06567>>34315000
         if not ucapam and not ucapsm then                     <<06567>>34320000
            begin                                              <<04.ro>>34325000
            cierr(errnum := listfamcap);                       <<04.ro>>34330000
            return                                             <<04.ro>>34335000
            end;                                               <<04.ro>>34340000
         end;                                                  <<04.ro>>34345000
      recipparms(13) := 0;                                     <<u.rao>>34350000
      end;  <<listf -1 case>>                                  <<u.rao>>34355000
   parms := parms(1);                                          <<u.rao>>34360000
   parms(1) := parms(2);  <<fixup for missing listlevel>>      <<u.rao>>34365000
   end                                                         <<u.rao>>34370000
else                                                           <<u.rao>>34375000
   tos := 0;   <<listlevel default>>                           <<u.rao>>34380000
recipparms(12) := s0;  <<listlevel in binary>>                 <<u.rao>>34385000
case tos of                                                    <<u.rao>>34390000
   begin   <<set width of entry in words>>                     <<u.rao>>34395000
   recipparms(13) := 4;                                        <<u.rao>>34400000
   recipparms(13) := 25;                                       <<u.rao>>34405000
   recipparms(13) := 34;                                       <<u.rao>>34410000
   end;                                                        <<u.rao>>34415000
<<we have now processed the listlevel. now do listfile>>       <<u.rao>>34420000
parmnum := parmnum+1;                                          <<u.rao>>34425000
if leafnamechar.(11:5)=semi then  <<probably is one>>         <<u.rao>>34430000
   begin                                                       <<u.rao>>34435000
   if cibadfilename(errnum,parms(1)) then return;              <<u.rao>>34440000
   stdlist := false;  <<user specified a file >>               <<u.rao>>34445000
   end                                                         <<u.rao>>34450000
else if leafnamechar.(11:5)=comma then  <<error>>              <<u.rao>>34455000
   begin                                                       <<u.rao>>34460000
   cierr(errnum := listfexpectfile, listfile);                 <<u.rao>>34465000
   return                                                      <<u.rao>>34470000
   end;                                                        <<u.rao>>34475000
                                                               <<u.rao>>34480000
if (listfilechar.(11:5) <> cr) and (extraparmlen<>0) then      <<u.rao>>34485000
   begin                                                       <<u.rao>>34490000
   parmnum := parmnum+1;                                       <<u.rao>>34495000
   cierr(errnum := listf2mp,extraparm);                        <<u.rao>>34500000
   return                                                      <<u.rao>>34505000
   end;                                                        <<u.rao>>34510000
parmnum := 0;                                                  <<u.rao>>34515000
                                                               <<u.rao>>34520000
if not stdlist then   <<open user defined file>>               <<u.rao>>34525000
fnum := fopen(listfile, foptions, %101);                       <<00267>>34530000
if carry then                                                  <<u.rao>>34535000
   begin                                                       <<u.rao>>34540000
   ferror'(fnum, parmnum);                                     <<u.rao>>34545000
   cierr(errnum := listffserr,listfile,%10000,parmnum);        <<u.rao>>34550000
   return                                                      <<u.rao>>34555000
   end;                                                        <<u.rao>>34560000
recipparms(18) := fnum;                                        <<u.rao>>34565000
                                                               <<u.rao>>34570000
fgetinfo(fnum,,foptions,,recipparms(19),dev);                  <<09.mm>>34575000
<< determine final domain of list file >>                      <<00852>>34580000
fclose'foptions.(13:3) := if foptions.(14:2) = new'file        <<00852>>34585000
                             then temp'domain                  <<00852>>34590000
                          else current'domain;                 <<00852>>34595000
tos := recipparms(19);                                         <<u.rao>>34600000
if < then tos := -tos                                          <<u.rao>>34605000
else tos := tos&lsl(1);  <<convert to byte count>>             <<u.rao>>34610000
recipparms(19) := tos;  <<line length>>                        <<u.rao>>34615000
                                                               <<u.rao>>34620000
<<set other file attributes>>                                  <<u.rao>>34625000
recipparms(20):=-1;                    <<1st-time line# flag>> <<05.km>>34630000
recipparms(21) := 0;                                           <<u.rao>>34635000
recipparms := fnum;                                            <<u.rao>>34640000
recipparms(1) := 0;                                            <<u.rao>>34645000
                                                               <<u.rao>>34650000
<<put out time stamp if job or list file>>                     <<02.ro>>34655000
pxglobal;                                                      <<06567>>34660000
interactive := pxg'interactive;                                <<06567>>34665000
if not interactive and stdlist or                              <<09.mm>>34670000
   not stdlist and dev.(8:8) >= 8  <<not disc>> then           <<03.ro>>34675000
   begin                                                       <<02.ro>>34680000
   <<if job and (stdlist of userfile is stdlist) do pageeject>><<09.mm>>34685000
   if not interactive and foptions.(10:3)=f'stdlist            <<09.mm>>34690000
      then pageeject;                                          <<09.mm>>34695000
   date'line(datebuf);                                         <<02.ro>>34700000
   fwrite(fnum, datebuf, -27, %60);                            <<02.ro>>34705000
   recipparms(20):=-3;                 <<1st-time line# flag>> <<05.km>>34710000
   end;                                                        <<02.ro>>34715000
                                                               <<02.ro>>34720000
p'gotentry:=false;                                             <<03.km>>34725000
p'impmntdst:=0;                                                <<03.km>>34730000
p'impmnterr:=nomnterr;                                         <<03.km>>34735000
if logical(d'inx1.(pvf)) then                                  <<03.km>>34740000
   begin                                                       <<03.km>>34745000
   comment:                                                    <<03.km>>34750000
     force acct-level search to ensure that we visit           <<03.km>>34755000
     group entry and force implicit mount;                     <<03.km>>34760000
                                                               <<03.km>>34765000
   d'type.(startlevelf):=1;                                    <<03.km>>34770000
   getdirinfo(1,2,ppresult);                                   <<03.km>>34775000
   end;                                                        <<03.km>>34780000
move p'ganame:=d'gname,(4),2; <<in case we don't visit node>>  <<06.km>>34785000
move * := d'aname,(4);                                         <<06.km>>34790000
recipparms (22) := d'type;                                    <<00.gen>>34795000
recipparms (23) := d'inx1;  <<glinkage initialization>>       <<00.gen>>34800000
recipparms(savebuffindex) := 0; << see syslist >>              <<04178>>34805000
recipparms(savebuffindex + asize + 1) := 0;                    <<04178>>34810000
                                                               <<rv.pv>>34815000
<<now set up common direcscan stuff on stack>>                 <<rv.pv>>34820000
tos := 0d;  <<return value>>                                   <<u.rao>>34825000
tos := d'type;                                                <<00.gen>>34830000
tos.(hitflag) := 1;                                            <<rv.pv>>34835000
tos := d'inx1.(mvtabxf);               <<linkage>>            <<04.gen>>34840000
tos := d'inx2;                         <<indexp>>             <<05.gen>>34845000
tos := @d'aname;                                              <<00.gen>>34850000
tos := @d'gname;                                              <<00.gen>>34855000
tos := @d'fname;                                              <<00.gen>>34860000
if recipparms(12)<0 then  <<listf ,-1>>                        <<u.rao>>34865000
   tos := direcscan(*,*,*,*,*,syslist,recipparms)              <<u.rao>>34870000
else                                                           <<u.rao>>34875000
   tos := direcscan(*,*,*,*,*,listsavefiles,recipparms);       <<u.rao>>34880000
                                                               <<04.km>>34885000
push(status);                                                  <<04.km>>34890000
if logical(p'gotentry) then fwrite(fnum,recipparms,0,0);       <<04.km>>34895000
if p'impmntdst<>0 or p'impmnterr<>nomnterr then                <<04.km>>34900000
  begin                                                        <<04.km>>34905000
  listfdismnt(p'impmntdst,p'impmnterr,p'impmntgrp,p'impmntacct,<<04.km>>34910000
              errnum);                                         <<04.km>>34915000
  if p'impmnterr>nomount and                                   <<04.km>>34920000
     jobsessionmain then genmsg(cierrmsgset,listfstopped);     <<04.km>>34925000
  end;                                                         <<04.km>>34930000
set(status);                                                   <<04.km>>34935000
                                                               <<04.km>>34940000
if <> then   <<directory error>>                               <<u.rao>>34945000
   begin                                                       <<u.rao>>34950000
   if not stdlist then   <<close user defined file>>           <<u.rao>>34955000
      fclose(fnum, fclose'foptions, 0);                        <<00852>>34960000
   cydirerr'(*,%120000,errnum);                                <<u.rao>>34965000
   return;                                                     <<u.rao>>34970000
   end;                                                        <<u.rao>>34975000
ddel;                                                          <<u.rao>>34980000
if recipparms(1) < 0 then                                      <<u.rao>>34985000
   begin                                                       <<u.rao>>34990000
   ferror'(fnum,parmnum);                                      <<u.rao>>34995000
   cierr(errnum := listffserr,listfile,%10000,parmnum);        <<u.rao>>35000000
   return                                                      <<u.rao>>35005000
   end;                                                        <<u.rao>>35010000
if logical(p'gotentry) then fwrite(fnum,recipparms,0,0)        <<03.km>>35015000
else cierr(errnum := -nofileslisted);                          <<04785>>35020000
             <<xparent to programmatic call for upward compat>><<03.km>>35025000
if not stdlist then  <<close user defined file>>               <<u.rao>>35030000
   fclose(fnum, fclose'foptions, 0);                           <<00852>>35035000
if carry then                                                  <<u.rao>>35040000
   begin                                                       <<u.rao>>35045000
   ferror'(fnum,parmnum);                                      <<u.rao>>35050000
   cierr(errnum := listffserr,listfile,%10000,parmnum);        <<u.rao>>35055000
   end;                                                        <<u.rao>>35060000
end;  <<cxlistf>>                                              <<u.rao>>35065000
                                                               <<01.km>>35070000
                                                               <<01.km>>35075000
$control segment = cipreprun                                   <<u.rao>>35080000
logical procedure cisubsysfinish(messagetype, errnum, parmnum);<<u.rao>>35085000
value messagetype;                                             <<u.rao>>35090000
integer messagetype, errnum, parmnum;                          <<u.rao>>35095000
option privileged, uncallable;                                 <<u.rao>>35100000
<<this procedure is called by all subsystem executors and the>><<u.rao>>35105000
<<executor for the run command.  it cleans up various job>>    <<u.rao>>35110000
<<related parameters and put out any appropriate termination>> <<u.rao>>35115000
<<message.>>                                                   <<u.rao>>35120000
<<messagetype = 0 => no message.                            >> <<u.rao>>35125000
<<            = 1 => "END OF PROGRAM"                       >> <<u.rao>>35130000
<<            = 2 => "END OF PREPARE"                       >> <<u.rao>>35135000
<<            = 3 => "END OF SUBSYSTEM"                     >> <<u.rao>>35140000
<<            = 4 => "END OF COMPILE"                       >> <<u.rao>>35145000
<<            = 5 => "END OF REMOTE PROGRAM"                >> <<u.rao>>35150000
begin                                                          <<u.rao>>35155000
logical result = cisubsysfinish;                               <<u.rao>>35160000
logical len;                                                   <<u.rao>>35165000
integer array jitarr(*) = db+0;                                <<06840>>35170000
logical jobsesstype;                                           <<06840>>35175000
integer jitjnum;  <<holds value of jitjnum>>                   <<u.rao>>35180000
integer jit'eof;                                               <<06840>>35185000
integer jitdstn;  <<holds dataseg number of jit>>              <<u.rao>>35190000
array qarray(*)=q+0;                                           <<06567>>35195000
integer pcbglobloc;                                            <<06567>>35200000
integer newjiteof := 0;  <<almost a dummy>>                    <<u.rao>>35205000
subroutine def'movefromdseg;                                   <<u.rao>>35210000
subroutine def'movetodseg;                                     <<u.rao>>35215000
                                                               <<u.rao>>35220000
nextline;  <<line feed>>                                       <<u.rao>>35225000
<<first deal with jit, getting and reseting eof and jnum>>     <<u.rao>>35230000
pxglobal;                                                      <<06567>>35235000
jitdstn := pxg'jitdst;                                         <<06567>>35240000
exchangedb(jitdstn);                                           <<06840>>35245000
jitjnum:=jitjobnumber;                                         <<06840>>35250000
jit'eof:=jiteof;                                               <<06840>>35255000
jobsesstype:=jitjstype;                                        <<06840>>35260000
jiteof:=newjiteof;    << clear old eof flags >>                <<06840>>35265000
exchangedb(0);                                                 <<06840>>35270000
<<set return value for subsysfinish>>                          <<u.rao>>35275000
cisubsysfinish := not getjcw.(0:1);                            <<u.rao>>35280000
<<flush to eod as necessary>>                                  <<u.rao>>35285000
if (jobsesstype = 2) <<job>> and (jit'eof <>0 )                <<07053>>35290000
   and (cis'udcnestlevel = 0) << not in udc >> then            << i.a >>35295000
   begin   <<flush required - read to :>>                      <<u.rao>>35300000
   do len := fread(1,cis'wcomimage,-cis'bcombuflen)            <<04920>>35305000
      until <> or cis'bcomimage = ":";                         << i.a >>35310000
   <<cce => found something, ccl/ccg => fread error or eof>>   <<u.rao>>35315000
   <<mpe used to look for : if $stdin or :eod if $stdinx, >>   <<u.rao>>35320000
   <<but the complexity and the imcompatibility with the  >>   <<u.rao>>35325000
   <<series i forced us to look for just a : in column 1. >>   <<u.rao>>35330000
   if = and len>1 then   <<success>>                           <<u.rao>>35335000
      cis'pendingcomlen := len;  << flag com already read >>   << i.a >>35340000
   end;                                                        <<u.rao>>35345000
<< reset the terminal to the desired state >>                  <<00851>>35350000
pxglobal;                                                      <<06567>>35355000
if pxg'interactive then reset'terminalmode;                    <<06567>>35360000
<<in any case, send message about process termination>>        <<u.rao>>35365000
if (messagetype <> 0) and result  <<pgm successful>> then      <<u.rao>>35370000
   genmsg(cigeneralmsgset, endofprog + messagetype -1);        <<u.rao>>35375000
<<finally, if appropriate, return abnormal term message>>      <<u.rao>>35380000
if not result then   <<fatal error somewhere>>                 <<u.rao>>35385000
   begin                                                       <<u.rao>>35390000
   parmnum := 0;                                               <<u.rao>>35395000
   if getjcw = %140000 then  <<:abort>>                        <<u.rao>>35400000
      cierr(errnum := pgmabort)                                <<u.rao>>35405000
   else   <<regular error>>                                    <<u.rao>>35410000
      cierr(errnum := errabterm);                              <<04785>>35415000
   end;                                                        <<u.rao>>35420000
end;   <<cisubsysfinish>>                                      <<u.rao>>35425000
procedure reset'terminalmode;                                  <<00851>>35430000
option uncallable;                                             <<00851>>35435000
begin                                                          <<00851>>35440000
   comment:                                                    <<00851>>35445000
      this procedure resets the terminal to the state          <<00851>>35450000
      desired by the ci.  in particular it:                    <<00851>>35455000
         1) disables break if in a nobreak udc else            <<00851>>35460000
            enables break                                      <<00851>>35465000
         2) cancells any previously established time-          <<00851>>35470000
            outs for freads.;                                  <<00851>>35475000
   logical                                                     <<00851>>35480000
      parm;  << fcontrol pararmeter >>                         <<00851>>35485000
                                                               <<00851>>35490000
   if cis'udcnobreakopt                                        << i.a >>35495000
      then fcontrol( 1, disablebreak, parm )                   << i.a >>35500000
   else fcontrol(1,enablebreak,parm);                          <<00851>>35505000
                                                               <<00851>>35510000
   << reset timed read >>                                      <<00851>>35515000
   parm := 0;                                                  <<00851>>35520000
   fcontrol(1,timeout,parm);                                   <<00851>>35525000
                                                               <<00851>>35530000
end; << procedure reset'terminalmode >>                        <<00851>>35535000
                                                               <<00851>>35540000
                                                               <<00851>>35545000
procedure cxpreprun executorhead;                              <<u.rao>>35550000
option privileged, uncallable;                                 <<u.rao>>35555000
begin                                                          <<u.rao>>35560000
  comment                                                      <<u.rao>>35565000
    handles :prep, :run, :preprun.                             <<u.rao>>35570000
                                                               <<u.rao>>35575000
algorithm: crash through in obvious fashion.  primarily driven <<u.rao>>35580000
   by "NEXT DELIMITER" and secondarily driven by the keywords; <<u.rao>>35585000
                                                               <<u.rao>>35590000
entry cxprep, cxrun;                                           <<u.rao>>35595000
                                                               <<u.rao>>35600000
byte array pkeylist(*)=pb:=                                    <<u.rao>>35605000
   5, 3, "LIB",                                                <<u.rao>>35610000
   9, 7, "MAXDATA",                                            <<u.rao>>35615000
   6, 4, "PARM",                                               <<u.rao>>35620000
   6, 4, "PMAP",                                               <<u.rao>>35625000
   7, 5, "DEBUG",                                              <<u.rao>>35630000
   7, 5, "STACK",                                              <<u.rao>>35635000
   4, 2, "RL",                                                 <<u.rao>>35640000
   6, 4, "LMAP",                                               <<u.rao>>35645000
   4, 2, "DL",                                                 <<u.rao>>35650000
   8, 6, "ZERODB",                                             <<u.rao>>35655000
   8, 6, "NOPRIV",                                             <<u.rao>>35660000
   6, 4, "NOCB",                                               <<u.rao>>35665000
   5, 3, "CAP",                                                <<u.rao>>35670000
   7, 5, "PATCH",                                              <<00629>>35675000
   7, 5, "STDIN",                                              <<01200>>35680000
   9, 7, "STDLIST",                                            <<01200>>35685000
   6, 4, "INFO",                                               <<01200>>35690000
   7, 5, "NOSYM",                                              <<04103>>35695000
   7, 5, "FPMAP",                                              <<04103>>35700000
   9, 7, "NOFPMAP",                                            <<04103>>35705000
  10, 8, "CHECKSUM",                                           <<04103>>35710000
   0;                                                          <<u.rao>>35715000
equate pkeylistl = 144;                                        <<04103>>35720000
byte array keylist(0:pkeylistl-1);                             <<u.rao>>35725000
byte array pcaplist(0:24)=pb:=                                 <<u.rao>>35730000
   4, 2, "PH",                                                 <<u.rao>>35735000
   4, 2, "DS",                                                 <<u.rao>>35740000
   4, 2, "MR",                                                 <<u.rao>>35745000
   4, 2, "PM",                                                 <<u.rao>>35750000
   4, 2, "IA",                                                 <<u.rao>>35755000
   4, 2, "BA",                                                 <<u.rao>>35760000
   0;                                                          <<u.rao>>35765000
equate pcaplistl = 25;                                         <<u.rao>>35770000
byte array caplist(0:pcaplistl-1);                             <<u.rao>>35775000
                                                               <<u.rao>>35780000
<<operational local variables>>                                <<u.rao>>35785000
integer preprunflag;                                           <<u.rao>>35790000
define prepcom = (preprunflag>0)#,                             <<u.rao>>35795000
       runcom  = (preprunflag<0)#,                             <<u.rao>>35800000
       prepruncom = (preprunflag=0)#;                          <<u.rao>>35805000
equate comma=0, equalsign=1, semicolon=2, cr=3;  <<delimiters>><<u.rao>>35810000
                                                               <<01426>>35815000
<< MAX LENGTH FOR A STRING COMES AFTER A 'RUN X;INFO="' >>     <<01426>>35820000
equate maxstringlen = cis'bcombuflen - 12;                     << i.a >>35825000
<< note that the current true maximum on string length is   >> <<01709>>35830000
<< 253 characters due to the limitation of mycommand.       >> <<01709>>35835000
                                                               <<01426>>35840000
integer numparms;                                              <<u.rao>>35845000
double array parms(0:maxstringlen+3-1);                        <<01426>>35850000
integer array iparms(*)=parms;                                 <<u.rao>>35855000
integer delimiter;                                             <<u.rao>>35860000
double tempparm,dusercap;                                      <<04172>>35865000
logical usercap = dusercap + 1;                                <<04172>>35870000
byte pointer ppntr=tempparm;                                   <<u.rao>>35875000
byte pointer tempparmptr = tempparm;                           <<02324>>35880000
logical dummy;                                                 <<02324>>35885000
byte pointer errptr;                                           <<02324>>35890000
logical lerrptr' = errptr;                                     <<02324>>35895000
logical parmword2=tempparm+1;                                  <<u.rao>>35900000
long                                                           <<04172>>35905000
   ia := [16/"IA",48/0]l,                                      <<04172>>35910000
   ba := [16/"BA",48/0]l,                                      <<04172>>35915000
   ib := [16/"IA",16/",B",16/"A ",16/0]l;                      <<04172>>35920000
byte x1=parmword2;  <<just a dummy for the following define>>  <<u.rao>>35925000
define parmlen = integer(x1)#;                                 <<u.rao>>35930000
integer maxparam;                                              <<u.rao>>35935000
integer err;                                                   <<u.rao>>35940000
integer namelen;          << length of file name >>            <<01200>>35945000
byte pointer sptr;        << target string >>                  <<01200>>35950000
byte array string(0:maxstringlen-1); << source string >>       <<01426>>35955000
byte array savedcomimage(0:cis'bcombuflen-1);                  << i.a >>35960000
integer t'ix,             << offset in target str >>           <<01200>>35965000
        s'ix;             << offset in source str >>           <<01200>>35970000
logical stop := false;    << flag to stop scanning >>          <<01200>>35975000
                          << if 'cr' or 'quotechar' >>         <<01200>>35980000
                          << is encountered. >>                <<01200>>35985000
byte quotechar;<< chosen string delimiter, can be >>           << i.a >>35990000
               << single or double quote.         >>           <<01200>>35995000
                                                               <<u.rao>>36000000
equate c'quote = %47,                                          <<01200>>36005000
       c'dquote = %42,                                         <<01200>>36010000
       c'comma =  %54,                                         <<01200>>36015000
       c'equal =  %75,                                         <<01200>>36020000
       c'semicolon = %73,                                      <<01200>>36025000
       c'cr = %15;                                             <<01200>>36030000
<<parsed parameter holders.  the actual values are    >>       <<u.rao>>36035000
<<entered in the section where the keywords are parsed>>       <<u.rao>>36040000
byte array progname(0:35);  <<program file name>>              <<u.rao>>36045000
logical blank := "  ";                                         <<u.rao>>36050000
byte array entryname(0:35);    <<entry point name>>            <<u.rao>>36055000
byte pointer rl := @blank;                                     <<u.rao>>36060000
byte array tfilename(0:8);  <<holds temp file names>>          <<u.rao>>36065000
byte array fullfilename(*) = keylist;                          <<u.rao>>36070000
logical parm := 0;                                             <<u.rao>>36075000
integer stacksize := -1;                                       <<u.rao>>36080000
integer dlsize := -1;                                          <<u.rao>>36085000
logical flags := 1;                                            <<u.rao>>36090000
logical flags'ext1 := 0;     << extension #1 to flags - for >> <<01200>>36095000
                             << noting duplicate keywords   >> <<01200>>36100000
byte array stdin(0:39);            << stdin string >>          <<01200>>36105000
byte array stdlist(0:70);          << stdlist string >>        <<01200>>36110000
integer maxdata := -1;                                         <<u.rao>>36115000
integer patchsize := -1;                                       <<00629>>36120000
byte lib := "S";                                               <<u.rao>>36125000
integer error;          << error return from createprocess >>  <<01200>>36130000
integer pin := 0;       << pin returned from createprocess >>  <<01200>>36135000
logical capword := 0;                                          <<u.rao>>36140000
logical pflags := 0;                                           <<u.rao>>36145000
integer array optnnums(0:12);   << options for createprocess >><<01200>>36150000
logical array optns(0:12);                                     <<01200>>36155000
logical options := 0;          << options for process create >><<01200>>36160000
                                                               <<u.rao>>36165000
define                                                         <<01200>>36170000
  stack'option    = options.(15:1)#,                           <<01200>>36175000
  dl'option       = options.(14:1)#,                           <<01200>>36180000
  maxdata'option  = options.(13:1)#,                           <<01200>>36185000
  stdin'option    = options.(12:1)#,                           <<01200>>36190000
  stdlist'option  = options.(11:1)#,                           <<01200>>36195000
  string'option   = options.(10:1)#;                           <<01200>>36200000
                                                               <<01200>>36205000
define                                                         <<u.rao>>36210000
  checkruncom=if runcom then errnum:=contxtprpnotrun#,         <<u.rao>>36215000
  checkprepcom=if prepcom then errnum:=contxtrunnotprp#,       <<u.rao>>36220000
  checkeqsign=if delimiter<>equalsign then                     <<u.rao>>36225000
     begin                                                     <<u.rao>>36230000
     @ppntr := @ppntr+parmlen;                                 <<u.rao>>36235000
     errnum := reqequalsign;                                   <<u.rao>>36240000
     end#,                                                     <<u.rao>>36245000
  checksegerr=                                                 <<u.rao>>36250000
     if <> and (err<>1) <<warning printed>> then               <<u.rao>>36255000
         begin                                                 <<u.rao>>36260000
         segmenter(pin,8,delimiter); <<exit>>                  <<u.rao>>36265000
         errnum := segmentererror;                             <<u.rao>>36270000
         parmnum := err;                                       <<u.rao>>36275000
         cierr(errnum,,%10000,err);                            <<u.rao>>36280000
         return;                                               <<u.rao>>36285000
         end #,                                                <<01200>>36290000
   checknew=                                                   <<01200>>36295000
      if parmlen <> 3 or ppntr <> "NEW" then                   <<01200>>36300000
       errnum := invalidstdlist#,                              <<01709>>36305000
                                                               <<01200>>36310000
   delim'char=                                                 <<01709>>36315000
       if delimiter = comma then c'comma                       <<01709>>36320000
       else if delimiter = equalsign then c'equal              <<01709>>36325000
       else if delimiter = semicolon then  c'semicolon         <<01709>>36330000
       else c'cr#;                                             <<01709>>36335000
equate                                                         <<01200>>36340000
  fatherwait      = 1,           << for calling awake >>       <<01200>>36345000
  sonwait         = 2;           << for calling awake >>       <<01200>>36350000
                                                               <<u.rao>>36355000
equate                                                         <<01452>>36360000
  unknown'prog    =  6;   << createproc. can't find program >> <<01452>>36365000
                                                               <<01200>>36370000
integer subroutine next;                                       <<u.rao>>36375000
begin  <<get next parameter>>                                  <<u.rao>>36380000
tempparm := parms(parmnum);                                    <<u.rao>>36385000
next := parmword2.(13:3);  <<return delimiter>>                <<u.rao>>36390000
parmnum := parmnum+1;                                          <<u.rao>>36395000
end;  <<subroutine next>>                                      <<u.rao>>36400000
                                                               <<01200>>36405000
logical subroutine delim(char);                                <<01200>>36410000
comment                                                        <<01200>>36415000
   the following subroutine determines if char is              <<01200>>36420000
   a delimiter. ;                                              <<01200>>36425000
byte char;                                                     <<01200>>36430000
begin                                                          <<01200>>36435000
   delim := false;                                             <<01200>>36440000
   if char = c'comma or                                        <<01200>>36445000
      char = c'equal or                                        <<01200>>36450000
      char = c'semicolon then                                  <<01200>>36455000
      delim := true;                                           <<01200>>36460000
end;                                                           <<01200>>36465000
                                                               <<u.rao>>36470000
<<*** main body of procedure ***>>                             <<u.rao>>36475000
                                                               <<u.rao>>36480000
preprunflag := 0;                                              <<u.rao>>36485000
maxparam := 29;                                                <<u.rao>>36490000
go to start;                                                   <<u.rao>>36495000
                                                               <<u.rao>>36500000
cxprep:                                                        <<u.rao>>36505000
preprunflag := 1;                                              <<u.rao>>36510000
maxparam := 21;                                                <<u.rao>>36515000
go to start;                                                   <<u.rao>>36520000
                                                               <<u.rao>>36525000
cxrun:                                                         <<u.rao>>36530000
preprunflag := -1;                                             <<u.rao>>36535000
<< make maxparam large so string of delimiters (i.e. ; , cr) >><<01426>>36540000
<< will be accepted by mycommand.                            >><<01426>>36545000
maxparam := maxstringlen + 3;                                  <<01426>>36550000
                                                               <<u.rao>>36555000
start:                                                         <<u.rao>>36560000
move savedcomimage := cis'bcomimage, (cis'bcombuflen);         << i.a >>36565000
mycommand(parmsp,,maxparam,numparms,parms);                    <<u.rao>>36570000
if carry then                                                  <<01709>>36575000
   begin  << an error from mycommand >>                        <<01709>>36580000
   << some parameter exceeds 255 characters >>                 <<01709>>36585000
   errnum := paramtoobig;                                      <<01709>>36590000
   cierr(errnum);                                              <<01709>>36595000
   return;                                                     <<01709>>36600000
   end;                                                        <<01709>>36605000
delimiter := next;                                             <<u.rao>>36610000
if numparms=0 then  <<missing first file name>>                <<u.rao>>36615000
   begin                                                       <<u.rao>>36620000
   errnum := if runcom then errnoprogf                         <<u.rao>>36625000
      else if prepruncom then errnoporuf                       <<u.rao>>36630000
      else errnouslf;                                          <<u.rao>>36635000
   cierr(errnum,parmsp(1));                                    <<u.rao>>36640000
   return;                                                     <<u.rao>>36645000
   end;                                                        <<u.rao>>36650000
                                                               <<u.rao>>36655000
<<check first file name>>                                      <<u.rao>>36660000
errnum := checkfilename'(tempparm&lsr(8),dummy,dummy,lerrptr');<<02324>>36665000
if < then    <<ccl returned , error in name >>                 <<02324>>36670000
    begin                                                      <<02324>>36675000
    cierr(errnum,errptr);   <<errptr pointing at error loc. >> <<02324>>36680000
    return;                                                    <<02324>>36685000
    end                                                        <<02324>>36690000
else if > and errnum <> 0 and errnum <> 3 then                 <<02324>>36695000
    begin                                                      <<02324>>36700000
    cierr(errnum := invalidsysdeffl,tempparmptr);              <<02324>>36705000
    return;                                                    <<02324>>36710000
    end                                                        <<02324>>36715000
else                                                           <<02324>>36720000
    if errnum = 3 then <<  $oldpass is allowed  >>             <<02324>>36725000
        errnum := 0;                                           <<02324>>36730000
move progname := ppntr,(parmlen);                              <<u.rao>>36735000
progname(parmlen) := " ";                                      <<u.rao>>36740000
                                                               <<u.rao>>36745000
<<next handle second file name, if any>>                       <<u.rao>>36750000
entryname := " ";                                              <<u.rao>>36755000
if delimiter = comma then  <<entry or progfile>>               <<u.rao>>36760000
   begin                                                       <<u.rao>>36765000
   delimiter := next;                                          <<u.rao>>36770000
   if prepcom then  <<check progfile name>>                    <<u.rao>>36775000
      if cibadfilename(errnum,tempparm) then  <<bad name!>>    <<u.rao>>36780000
         begin                                                 <<u.rao>>36785000
         parmnum := 2;                                         <<u.rao>>36790000
         return;                                               <<u.rao>>36795000
         end                                                   <<u.rao>>36800000
      else                                                     <<u.rao>>36805000
   else if parmlen>15 then  <<entry name too long>>            <<u.rao>>36810000
      begin                                                    <<u.rao>>36815000
      cierr(errnum := errentrytoobig,ppntr);                   <<u.rao>>36820000
      parmnum := 2;                                            <<u.rao>>36825000
      return                                                   <<u.rao>>36830000
      end;                                                     <<u.rao>>36835000
   move entryname := ppntr,(parmlen);                          <<u.rao>>36840000
   entryname(parmlen) := " ";                                  <<u.rao>>36845000
   end                                                         <<u.rao>>36850000
else if prepcom then  <<missing required prog file>>           <<u.rao>>36855000
   begin                                                       <<u.rao>>36860000
   errnum := errnopreptarget;                                  <<u.rao>>36865000
   parmnum := 2;                                               <<u.rao>>36870000
   cierr(errnum,ppntr(parmlen));                               <<u.rao>>36875000
   return                                                      <<u.rao>>36880000
   end;                                                        <<u.rao>>36885000
                                                               <<u.rao>>36890000
<<next we do a case on the delimiter following the file>>      <<u.rao>>36895000
<<names.  carriage return falls through>>                      <<u.rao>>36900000
case delimiter of                                              <<u.rao>>36905000
   begin                                                       <<u.rao>>36910000
      begin  <<comma, quite unexpected>>                       <<u.rao>>36915000
         errnum := cmaxpctsemiorcr;                            <<u.rao>>36920000
         cierr(errnum,ppntr(parmlen));                         <<u.rao>>36925000
         return;                                               <<u.rao>>36930000
      end;                                                     <<u.rao>>36935000
      begin  <<equal sign, similarly unexpected>>              <<u.rao>>36940000
         errnum := eqxpctsemiorcr;                             <<u.rao>>36945000
         cierr(errnum,ppntr(parmlen));                         <<u.rao>>36950000
         return;                                               <<u.rao>>36955000
      end;                                                     <<u.rao>>36960000
      begin  <<semicolon - keyword(s) follow>>                 <<u.rao>>36965000
      move keylist := pkeylist,(pkeylistl);                    <<u.rao>>36970000
      tos := flags;                                            <<u.rao>>36975000
      do    <<parse keyword list>>                             <<u.rao>>36980000
         begin                                                 <<u.rao>>36985000
         delimiter := next;                                    <<u.rao>>36990000
         if parmlen=0 then                                     <<u.rao>>36995000
                cierr(-extrndelimignrd,ppntr(-1))              <<04919>>37000000
            else                                               <<u.rao>>37005000
               begin   <<keyword processing>>                  <<u.rao>>37010000
               case search(ppntr,parmlen,keylist) of           <<u.rao>>37015000
                  begin                                        <<u.rao>>37020000
                                                               <<u.rao>>37025000
                     <<the tomb of the unknown keyword>>       <<u.rao>>37030000
                  errnum := (if prepcom then unknownkeyprep    <<u.rao>>37035000
                     else if runcom then unknownkeyrun         <<u.rao>>37040000
                     else unknownkeyprprn);                    <<u.rao>>37045000
                                                               <<u.rao>>37050000
                     <<lib = sl>>                              <<u.rao>>37055000
                  checkprepcom                                 <<u.rao>>37060000
                  else checkeqsign                             <<u.rao>>37065000
                  else                                         <<u.rao>>37070000
                     begin  <<check the value>>                <<u.rao>>37075000
                     delimiter := next;                        <<u.rao>>37080000
                     if (parmlen=1) and ((ppntr="G")           <<u.rao>>37085000
                        or (ppntr="P") or (ppntr="S")) then    <<u.rao>>37090000
                        begin  <<valid lib>>                   <<u.rao>>37095000
                        lib := ppntr;                          <<u.rao>>37100000
                        assemble(tsbc 4);                      <<u.rao>>37105000
                        end                                    <<u.rao>>37110000
                     else                                      <<u.rao>>37115000
                        errnum := invalidlib;                  <<u.rao>>37120000
                     end;                                      <<u.rao>>37125000
                                                               <<u.rao>>37130000
                     <<maxdata = segsize>>                     <<u.rao>>37135000
                  checkeqsign                                  <<u.rao>>37140000
                  else                                         <<u.rao>>37145000
                     begin                                     <<u.rao>>37150000
                     delimiter := next;                        <<u.rao>>37155000
                     if parmlen > 0 then                       <<u.rao>>37160000
                        begin                                  <<u.rao>>37165000
                        maxdata := binary(ppntr,parmlen);      <<u.rao>>37170000
                        if <> then                             <<u.rao>>37175000
                           errnum := invalidmaxdata            <<u.rao>>37180000
                        else                                   <<u.rao>>37185000
                           begin                               <<u.rao>>37190000
                           maxdata'option := 1;                <<01200>>37195000
                           assemble(tsbc 0);                   <<u.rao>>37200000
                           end;                                <<u.rao>>37205000
                        end                                    <<u.rao>>37210000
                     else                                      <<u.rao>>37215000
                        errnum := invalidmaxdata;              <<u.rao>>37220000
                     end;                                      <<u.rao>>37225000
                                                               <<u.rao>>37230000
                     <<parm = parm>>                           <<u.rao>>37235000
                  checkprepcom                                 <<u.rao>>37240000
                  else checkeqsign                             <<u.rao>>37245000
                  else                                         <<u.rao>>37250000
                     begin                                     <<u.rao>>37255000
                     delimiter := next;                        <<u.rao>>37260000
                     if parmlen>0 then                         <<u.rao>>37265000
                        begin                                  <<u.rao>>37270000
                        parm := binary(ppntr,parmlen);         <<u.rao>>37275000
                        if <> then                             <<u.rao>>37280000
                           errnum := invalidparm               <<u.rao>>37285000
                        else                                   <<u.rao>>37290000
                           assemble(tsbc 1);                   <<u.rao>>37295000
                        end                                    <<u.rao>>37300000
                     else                                      <<u.rao>>37305000
                        errnum := invalidparm;                 <<u.rao>>37310000
                     end;                                      <<u.rao>>37315000
                                                               <<u.rao>>37320000
                     <<pmap>>                                  <<u.rao>>37325000
                  checkruncom else assemble(tsbc 6);           <<u.rao>>37330000
                                                               <<u.rao>>37335000
                     <<debug>>                                 <<u.rao>>37340000
                  checkprepcom else assemble(tsbc 13);         <<u.rao>>37345000
                                                               <<u.rao>>37350000
                     <<stack = stacksize>>                     <<u.rao>>37355000
                  checkeqsign                                  <<u.rao>>37360000
                  else                                         <<u.rao>>37365000
                     begin                                     <<u.rao>>37370000
                     delimiter := next;                        <<u.rao>>37375000
                     if parmlen > 0 then                       <<u.rao>>37380000
                        begin                                  <<u.rao>>37385000
                        stacksize := binary(ppntr,parmlen);    <<u.rao>>37390000
                        if <> or (stacksize<511) then          <<u.rao>>37395000
                           errnum := invalidstaksize           <<u.rao>>37400000
                        else                                   <<u.rao>>37405000
                           begin                               <<u.rao>>37410000
                           stack'option := 1;                  <<01200>>37415000
                           assemble(tsbc 2);                   <<u.rao>>37420000
                           end                                 <<u.rao>>37425000
                        end                                    <<u.rao>>37430000
                     else                                      <<u.rao>>37435000
                        errnum := invalidstaksize;             <<u.rao>>37440000
                  end;                                         <<u.rao>>37445000
                                                               <<u.rao>>37450000
                     <<rl = filename>>                         <<u.rao>>37455000
                  checkruncom                                  <<u.rao>>37460000
                  else checkeqsign                             <<u.rao>>37465000
                  else                                         <<u.rao>>37470000
                     begin                                     <<u.rao>>37475000
                     delimiter := next;                        <<u.rao>>37480000
                     tos := checkfilename'(tempparm&lsr(8),    <<u.rao>>37485000
                        maxparam,maxparam,err);                <<u.rao>>37490000
                     if >= then                                <<u.rao>>37495000
                        begin                                  <<u.rao>>37500000
                        del;                                   <<u.rao>>37505000
                        @rl := @ppntr;                         <<u.rao>>37510000
                        assemble(tsbc 8)                       <<u.rao>>37515000
                        end                                    <<u.rao>>37520000
                     else  <<correct caret ptr for cierr>>     <<u.rao>>37525000
                        begin                                  <<u.rao>>37530000
                        @ppntr := err;                         <<u.rao>>37535000
                        errnum := tos;                         <<u.rao>>37540000
                        end;                                   <<u.rao>>37545000
                     end;                                      <<u.rao>>37550000
                                                               <<u.rao>>37555000
                     <<lmap>>                                  <<u.rao>>37560000
                  checkprepcom else assemble(tsbc 14);         <<u.rao>>37565000
                                                               <<u.rao>>37570000
                     <<dl = dlsize>>                           <<u.rao>>37575000
                  checkeqsign                                  <<u.rao>>37580000
                  else                                         <<u.rao>>37585000
                     begin                                     <<u.rao>>37590000
                     delimiter := next;                        <<u.rao>>37595000
                     if parmlen > 0 then                       <<u.rao>>37600000
                        begin                                  <<u.rao>>37605000
                        dlsize := binary(ppntr,parmlen);       <<u.rao>>37610000
                        if <> then                             <<u.rao>>37615000
                           errnum := invaliddlsize             <<u.rao>>37620000
                        else                                   <<u.rao>>37625000
                           begin                               <<u.rao>>37630000
                           dl'option := 1;                     <<01200>>37635000
                           assemble(tsbc 3);                   <<u.rao>>37640000
                           end                                 <<u.rao>>37645000
                        end                                    <<u.rao>>37650000
                     else                                      <<u.rao>>37655000
                        errnum := invaliddlsize;               <<u.rao>>37660000
                     end;                                      <<u.rao>>37665000
                                                               <<u.rao>>37670000
                     <<zerodb>>                                <<u.rao>>37675000
                  checkruncom else assemble(tsbc 11);          <<u.rao>>37680000
                                                               <<u.rao>>37685000
                     <<nopriv>>                                <<u.rao>>37690000
                  checkprepcom else assemble(tsbc 12);         <<u.rao>>37695000
                                                               <<u.rao>>37700000
                     <<nocb>>                                  <<u.rao>>37705000
                  checkprepcom else assemble(tsbc 9);          <<u.rao>>37710000
                                                               <<u.rao>>37715000
                     <<cap>>                                   <<u.rao>>37720000
                  checkruncom                                  <<u.rao>>37725000
                  else checkeqsign                             <<u.rao>>37730000
                  else                                         <<u.rao>>37735000
                     begin                                     <<u.rao>>37740000
                     move caplist := pcaplist,(pcaplistl);     <<u.rao>>37745000
                     tos := 0;  <<future capabilities word>>   <<u.rao>>37750000
                     do begin                                  <<u.rao>>37755000
                        delimiter := next;                     <<u.rao>>37760000
                        if parmlen = 0 then                    <<u.rao>>37765000
                           errnum := missingcap                <<u.rao>>37770000
                        else                                   <<u.rao>>37775000
                           case search(ppntr,parmlen,caplist)of<<u.rao>>37780000
                              begin                            <<u.rao>>37785000
                              begin errnum := unknowncap;      <<u.rao>>37790000
                                 @ppntr:=@ppntr-1;end;         <<u.rao>>37795000
                              assemble(tsbc 15);  <<ph>>       <<u.rao>>37800000
                              assemble(tsbc 14);  <<ds>>       <<u.rao>>37805000
                              assemble(tsbc 12);  <<mr>>       <<u.rao>>37810000
                              assemble(tsbc 9);   <<pm>>       <<u.rao>>37815000
                              assemble(tsbc 8);   <<ia>>       <<u.rao>>37820000
                              assemble(tsbc 7);   <<ba>>       <<u.rao>>37825000
                              end;                             <<u.rao>>37830000
                        end                                    <<u.rao>>37835000
                           until (delimiter <> comma) or       <<u.rao>>37840000
                              (errnum <> 0);                   <<u.rao>>37845000
                     capword := tos;                           <<u.rao>>37850000
                     if (capword.(7:2)=0) and (errnum=0) then <<*alt*>> 37855000
                        begin                                  <<04172>>37860000
                        who(,dusercap);                        <<04172>>37865000
                        capword.(7:2) := usercap.(7:2);        <<04172>>37870000
                        case usercap.(7:2) of                  <<04172>>37875000
                           begin                               <<04172>>37880000
                           ;                                   <<04172>>37885000
                         << note that assignments to >>        <<04919>>37890000
                         << errnum are not necessary >>        <<04919>>37895000
                         << since :prep and :preprun >>        <<04919>>37900000
                         << are not executed progam- >>        <<04919>>37905000
                         << matically  only warnings >>        <<04919>>37910000
                         cierr(-impiaba,,0,@ia&lsl(1));        <<04919>>37915000
                         cierr(-impiaba,,0,@ba&lsl(1));        <<04919>>37920000
                         cierr(-impiaba,,0,@ib&lsl(1));        <<04919>>37925000
                           end;                                <<04172>>37930000
                        end;                                   <<04172>>37935000
                     assemble(tsbc 7);                         <<u.rao>>37940000
                     end;                                      <<u.rao>>37945000
                                                               <<00629>>37950000
                     <<patch = patchsize>>                     <<00629>>37955000
                  checkruncom                                  <<00629>>37960000
                  else checkeqsign                             <<00629>>37965000
                  else                                         <<00629>>37970000
                     begin                                     <<00629>>37975000
                     delimiter := next;                        <<00629>>37980000
                     if parmlen > 0 then                       <<00629>>37985000
                        begin                                  <<00629>>37990000
                        patchsize := binary(ppntr,parmlen);    <<00629>>37995000
                        if <> then                             <<00629>>38000000
                           errnum := invalidpatch              <<00629>>38005000
                        else                                   <<00629>>38010000
                           begin                               <<00629>>38015000
                           if not(-1<= patchsize <=16380) then <<00629>>38020000
                              errnum := invalidpatch;          <<00629>>38025000
                           assemble(tsbc 5);                   <<00629>>38030000
                           end;                                <<00629>>38035000
                        end                                    <<00629>>38040000
                     else                                      <<00629>>38045000
                        errnum := invalidpatch;                <<00629>>38050000
                     end;                                      <<00629>>38055000
                                                               <<00629>>38060000
                     << stdin = file >>                        <<01200>>38065000
                  checkprepcom                                 <<01200>>38070000
                  else checkeqsign                             <<01200>>38075000
                  else                                         <<01200>>38080000
                     begin                                     <<01200>>38085000
                     stdin'option := 0;                        <<01200>>38090000
                     delimiter := next;                        <<01200>>38095000
                     if parmlen > 0 then                       <<01200>>38100000
                        begin  << stdin really specified >>    <<01200>>38105000
                        stdin'option := 1;                     <<01200>>38110000
                        tos := checkfilename'(tempparm&lsr(8), <<01200>>38115000
                                              maxparam,        <<01200>>38120000
                                              maxparam,        <<01200>>38125000
                                              err);            <<01200>>38130000
                        if = then                              <<01200>>38135000
                           begin  << simple file name >>       <<01200>>38140000
                           del;   << return value >>           <<01200>>38145000
                           move stdin := ppntr,(parmlen),2;    <<01200>>38150000
                           move * := ",OLD";                   <<01200>>38155000
                           stdin(parmlen+4) := c'cr;           <<01200>>38160000
                           end                                 <<01200>>38165000
                        else if > then                         <<01200>>38170000
                           begin  << special file >>           <<01200>>38175000
                           if s0 = 0 or s0 = 6 then            <<01200>>38180000
                              begin  << backref or $null >>    <<01200>>38185000
                              del;   << return value >>        <<01200>>38190000
                              move stdin := ppntr,(parmlen);   <<01200>>38195000
                              stdin(parmlen) := c'cr;          <<01200>>38200000
                              end                              <<01200>>38205000
                           else                                <<01200>>38210000
                              begin  << not backref/$null >>   <<01200>>38215000
                              del;   << return value >>        <<01200>>38220000
                              errnum := invalidstdin;          <<01200>>38225000
                              end;                             <<01200>>38230000
                           end                                 <<01200>>38235000
                        else                                   <<01200>>38240000
                           begin  << bad file name >>          <<01200>>38245000
                           @ppntr := err;                      <<01200>>38250000
                           errnum := tos;                      <<01200>>38255000
                           end;                                <<01200>>38260000
                        end;                                   <<01200>>38265000
                     tos := flags'ext1;                        <<01200>>38270000
                     assemble (tsbc 15);                       <<01200>>38275000
                     flags'ext1 := tos;                        <<01200>>38280000
                     end << stdin = filename >>;               <<01200>>38285000
                                                               <<01200>>38290000
                     << stdlist = file >>                      <<01200>>38295000
                  checkprepcom                                 <<01200>>38300000
                  else checkeqsign                             <<01200>>38305000
                  else                                         <<01200>>38310000
                     begin                                     <<01200>>38315000
                     stdlist'option := 0;                      <<01200>>38320000
                     delimiter := next;                        <<01200>>38325000
                     if parmlen > 0 then                       <<01200>>38330000
                        begin  << stdlist really specified >>  <<01200>>38335000
                        stdlist'option := 1;                   <<01200>>38340000
                        tos := checkfilename'(tempparm&lsr(8), <<01200>>38345000
                                              maxparam,        <<01200>>38350000
                                              maxparam,        <<01200>>38355000
                                              err);            <<01200>>38360000
                        if < then                              <<01200>>38365000
                           begin  << bad file name >>          <<01200>>38370000
                           @ppntr := err;                      <<01200>>38375000
                           errnum := tos;                      <<01200>>38380000
                           end                                 <<01200>>38385000
                        else if > then                         <<01200>>38390000
                           begin  << special file >>           <<01200>>38395000
                           if s0 = 0 or s0 = 6 then            <<01200>>38400000
                              begin  << backref or $null >>    <<01200>>38405000
                              del;   << return value >>        <<01200>>38410000
                              move stdlist := ppntr,(parmlen); <<01200>>38415000
                              stdlist(parmlen) := c'cr;        <<01200>>38420000
                              end                              <<01200>>38425000
                           else                                <<01200>>38430000
                              begin  << not backref/$null >>   <<01200>>38435000
                              del;   << return value >>        <<01200>>38440000
                              errnum := invalidstdlist;        <<01200>>38445000
                              end;                             <<01200>>38450000
                           end                                 <<01200>>38455000
                        else                                   <<01200>>38460000
                           begin  << simple file name >>       <<01200>>38465000
                           del;   << return value >>           <<01200>>38470000
                           move stdlist := ppntr,(parmlen),2;  <<01200>>38475000
                           if delimiter <> comma then          <<01200>>38480000
                              begin  << must be old file >>    <<01200>>38485000
                              move * := ",OLD";                <<01200>>38490000
                              stdlist(parmlen+4) := c'cr;      <<01200>>38495000
                              end                              <<01200>>38500000
                           else                                <<01200>>38505000
                              begin  << possibly new file >>   <<01200>>38510000
                              namelen := parmlen;              <<01200>>38515000
                              delimiter := next;               <<01200>>38520000
                              checknew                         <<01200>>38525000
                              else                             <<01200>>38530000
                                 begin  << a new file >>       <<01200>>38535000
                                 move * := (",NEW;REC=-132",   <<01200>>38540000
                                            ",,F,ASCII;",      <<01200>>38545000
                                            "ACC=OUT;TEMP");   <<01200>>38550000
                                 stdlist(namelen+35) := c'cr;  <<01200>>38555000
                                 end;                          <<01200>>38560000
                              end;                             <<01200>>38565000
                           end << valid file name >>;          <<01200>>38570000
                        end << $stdlist specified >>;          <<01200>>38575000
                     tos := flags'ext1;                        <<01200>>38580000
                     assemble (tsbc 14);                       <<01200>>38585000
                     flags'ext1 := tos;                        <<01200>>38590000
                     end << stdlist = file >>;                 <<01200>>38595000
                                                               <<01200>>38600000
                     << info = string >>                       <<01200>>38605000
                  checkprepcom                                 <<01200>>38610000
                  else checkeqsign                             <<01200>>38615000
                  else                                         <<01200>>38620000
                     begin                                     <<01200>>38625000
                     delimiter := next;                        <<01200>>38630000
                     if ppntr<>c'quote and ppntr<>c'dquote     <<01200>>38635000
                        then errnum := expctquote              <<01200>>38640000
                     else                                      <<01200>>38645000
                        begin                                  <<01200>>38650000
                        string'option := 1;                    <<01200>>38655000
                        quotechar := ppntr;                    <<01200>>38660000
                        x := @ppntr - @cis'bcomimage + 1;      << i.a >>38665000
                        @sptr := @savedcomimage(x);            <<01426>>38670000
                        t'ix := s'ix := -1;                    <<01200>>38675000
                        do                                     <<01200>>38680000
                           begin                               <<01200>>38685000
                           while sptr(s'ix:=s'ix+1)<>quotechar <<01200>>38690000
                               and integer(sptr(s'ix))<>c'cr do<<01200>>38695000
                              begin                            <<01200>>38700000
                              if delim(sptr(s'ix)) then        <<01200>>38705000
                                 delimiter := next;            <<01200>>38710000
                              string(t'ix:=t'ix+1):=sptr(s'ix);<<01200>>38715000
                              end;                             <<01200>>38720000
                           if sptr(s'ix) = c'cr then           <<01200>>38725000
                              begin                            <<01200>>38730000
                              << force ptr to end of string >> <<01200>>38735000
                              @ppntr := @ppntr(parmlen);       <<01200>>38740000
                              errnum := expctclosequote;       <<01200>>38745000
                              stop := true;                    <<01200>>38750000
                              end                              <<01200>>38755000
                           else if sptr(s'ix:=s'ix+1)=quotechar<<01709>>38760000
                              then string(t'ix:=t'ix+1):=      <<01709>>38765000
                                      quotechar                <<01709>>38770000
                           else                                <<01709>>38775000
                              begin  << should be end of str >><<01709>>38780000
                              stop := true;                    <<01709>>38785000
                              << make sure there's nothing  >> <<01709>>38790000
                              << between quote & delimiter  >> <<01709>>38795000
                              tos := "  ";                     <<01709>>38800000
                              tos.(0:8) := delim'char;         <<01709>>38805000
                              scan sptr(s'ix) while *;         <<01709>>38810000
                              if nocarry then                  <<01709>>38815000
                                 begin  <<something unexpctd>> <<01709>>38820000
                                 errnum := xpctsemiorcr;       <<01709>>38825000
                                 @ppntr := @ppntr(s'ix+1);     <<01709>>38830000
                                 end;                          <<01709>>38835000
                              end;                             <<01709>>38840000
                           end                                 <<01200>>38845000
                              until stop;                      <<01200>>38850000
                        t'ix := t'ix + 1;                      <<01200>>38855000
                        if t'ix > 253 and errnum = 0 then      <<01709>>38860000
                           errnum := stringtoobig;             <<01709>>38865000
                        end;                                   <<01200>>38870000
                     tos := flags'ext1;                        <<01200>>38875000
                     assemble (tsbc 13);                       <<01200>>38880000
                     flags'ext1 := tos;                        <<01200>>38885000
                     end << info = string >>;                  <<01200>>38890000
                     <<nosym>>                                 <<04103>>38895000
                  checkruncom                                  <<04103>>38900000
                  else                                         <<04103>>38905000
                     begin                                     <<04103>>38910000
                     tos := flags'ext1;                        <<04103>>38915000
                     assemble (tsbc 12);                       <<04103>>38920000
                     flags'ext1 := tos;                        <<04103>>38925000
                     end;                                      <<04103>>38930000
                                                               <<04103>>38935000
   <<**********   fpmap   ******************>>                 <<04103>>38940000
                  checkruncom                                  <<04103>>38945000
                  else                                         <<04103>>38950000
                     begin                                     <<04103>>38955000
                     tos := flags'ext1;                        <<04103>>38960000
                     assemble (tsbc 11);                       <<04103>>38965000
                     flags'ext1 := tos;                        <<04103>>38970000
                     end;                                      <<04103>>38975000
    <<*********   nofpmap  *****************>>                 <<04103>>38980000
                  checkruncom                                  <<04103>>38985000
                  else                                         <<04103>>38990000
                     begin                                     <<04103>>38995000
                     tos := flags'ext1;                        <<04103>>39000000
                     assemble (tsbc 10);                       <<04103>>39005000
                     flags'ext1 := tos;                        <<04103>>39010000
                     end;                                      <<04103>>39015000
     <<**********  checksum   **************>>                 <<04103>>39020000
                  checkruncom                                  <<04103>>39025000
                  else                                         <<04103>>39030000
                     begin                                     <<04103>>39035000
                     tos := flags'ext1;                        <<04103>>39040000
                     assemble (tsbc 9 );                       <<04103>>39045000
                     flags'ext1 := tos;                        <<04103>>39050000
                     end;    <<checksum>>                      <<04103>>39055000
                  end;  <<of case on keywords>>                <<u.rao>>39060000
               if <> and (errnum=0) then                       <<u.rao>>39065000
                  begin                                        <<u.rao>>39070000
                  tos:=-warnduplkey;                           <<u.rao>>39075000
                  tos:=parms(parmnum-2);                       <<u.rao>>39080000
                  if tos.(14:2)<>equalsign then                <<u.rao>>39085000
                     begin                                     <<u.rao>>39090000
                     del;                                      <<u.rao>>39095000
                     tos := @ppntr;                            <<u.rao>>39100000
                     end;                                      <<u.rao>>39105000
                  cierr(*,*);                                  <<u.rao>>39110000
                  end;                                         <<u.rao>>39115000
               if errnum <> 0 then                             <<u.rao>>39120000
                  begin                                        <<u.rao>>39125000
                  cierr(errnum,ppntr);                         <<u.rao>>39130000
                  return                                       <<u.rao>>39135000
                  end;                                         <<u.rao>>39140000
               end                                             <<u.rao>>39145000
            end                                                <<u.rao>>39150000
               until delimiter <> semicolon;                   <<u.rao>>39155000
                                                               <<u.rao>>39160000
         <<now cleanup after keyword processing>>              <<u.rao>>39165000
         flags := tos;                                         <<u.rao>>39170000
         if delimiter <> cr then                               <<u.rao>>39175000
            begin                                              <<u.rao>>39180000
            if delimiter = comma then                          <<u.rao>>39185000
               errnum := cmaxpctsemiorcr                       <<u.rao>>39190000
            else                                               <<u.rao>>39195000
               errnum := eqxpctsemiorcr;                       <<u.rao>>39200000
            cierr(errnum,ppntr(parmlen));                      <<01426>>39205000
            return                                             <<u.rao>>39210000
            end;                                               <<u.rao>>39215000
         end;  <<keyword processing>>                          <<u.rao>>39220000
      end;  <<case on delimiters>>                             <<u.rao>>39225000
                                                               <<u.rao>>39230000
                                                               <<u.rao>>39235000
<<the command has now been entirely parsed.  it simply >>      <<u.rao>>39240000
<<remains to execute it if possible>>                          <<u.rao>>39245000
                                                               <<00830>>39250000
if prepruncom then  <<establish passed file as prog file>>     <<u.rao>>39255000
   move tfilename := "$NEWPASS "                               <<u.rao>>39260000
else if prepcom then                                           <<u.rao>>39265000
   @tfilename := @entryname;                                   <<u.rao>>39270000
setjcw(getjcw land %37777);  <<clear jcw abort bits>>          <<02.mm>>39275000
if not runcom then  <<do prep stage>>                          <<u.rao>>39280000
   begin                                                       <<u.rao>>39285000
   if flags'ext1.(10:2) = 3 then <<fpmap/nofpmap both >>       <<04103>>39290000
   begin                         <<have been specified >>      <<04103>>39295000
      errnum := bothfpmapnofpmap;                              <<04103>>39300000
      cierr(errnum,ppntr(parmlen));                            <<04103>>39305000
      return;                                                  <<04103>>39310000
   end;                                                        <<04103>>39315000
   pflags := flags.(6:1); <<pmap>>                             <<u.rao>>39320000
   pflags.(14:1) := flags.(11:1);  <<zerodb>>                  <<u.rao>>39325000
   pflags.(9:1) := flags'ext1.(12:1); <<nosym>>                <<04103>>39330000
   pflags.(8:1) := flags'ext1.(11:1);  << fpmap >>             <<04103>>39335000
   pflags.(7:1) := flags'ext1.(10:1);  << nofpmap >>           <<04103>>39340000
   pflags.(6:1) := flags'ext1.(9:1);   <<checksum >>           <<04103>>39345000
   err := 0;  <<reinitialize>>                                 <<u.rao>>39350000
   segmenter(pin,22,err,,,,,,,,,progname); <<create segmenter>><<00629>>39355000
   checksegerr;                                                <<u.rao>>39360000
   segmenter(pin,14,err,stacksize,dlsize,pflags,maxdata,       <<00629>>39365000
      capword,patchsize,,,tfilename,rl);                       <<00629>>39370000
   checksegerr;                                                <<u.rao>>39375000
   segmenter(pin,8,err);  <<exit>>                             <<u.rao>>39380000
   if prepcom then   <<just a prepare, exit>>                  <<u.rao>>39385000
      begin                                                    <<u.rao>>39390000
      cisubsysfinish(2, errnum, parmnum);                      <<u.rao>>39395000
      return                                                   <<u.rao>>39400000
      end;                                                     <<u.rao>>39405000
                                                               <<u.rao>>39410000
   <<now clean up after segmenter>>                            <<u.rao>>39415000
   if not cisubsysfinish(2, errnum, parmnum) then              <<u.rao>>39420000
      return;                                                  <<u.rao>>39425000
   move tfilename := "$OLD";                                   <<u.rao>>39430000
   @progname := @tfilename;                                    <<u.rao>>39435000
   end;  <<of prepare phase>>                                  <<u.rao>>39440000
                                                               <<u.rao>>39445000
<<now do run phase>>                                           <<u.rao>>39450000
flags := flags land %117;  <<eliminate prep flags>>            <<u.rao>>39455000
if lib="P" then flags.(11:1):=1                                <<u.rao>>39460000
else if lib="G" then flags.(10:1):=1;                          <<u.rao>>39465000
tos := tos+0;  <<clear carry>>                                 <<u.rao>>39470000
<< set up to create the new process to run the program >>      <<01200>>39475000
optnnums(0) := 1;   optns(0) := @entryname;                    <<01200>>39480000
optnnums(1) := 2;   optns(1) := parm;                          <<01200>>39485000
optnnums(2) := 3;   optns(2) := flags;                         <<01200>>39490000
x := 3;                                                        <<01200>>39495000
if stack'option then                                           <<01200>>39500000
   begin  << stacksize was specified >>                        <<01200>>39505000
   optnnums(x) := 4;   optns(x) := stacksize;                  <<01200>>39510000
   x := x + 1;                                                 <<01200>>39515000
   end;                                                        <<01200>>39520000
if dl'option then                                              <<01200>>39525000
   begin  << dlsize was specified >>                           <<01200>>39530000
   optnnums(x) := 5;   optns(x) := dlsize;                     <<01200>>39535000
   x := x + 1;                                                 <<01200>>39540000
   end;                                                        <<01200>>39545000
if maxdata'option then                                         <<01200>>39550000
   begin  << maxdata was specified >>                          <<01200>>39555000
   optnnums(x) := 6;   optns(x) := maxdata;                    <<01200>>39560000
   x := x + 1;                                                 <<01200>>39565000
   end;                                                        <<01200>>39570000
if stdin'option then                                           <<01200>>39575000
   begin  << stdin was specified >>                            <<01200>>39580000
   optnnums(x) := 8;   optns(x) := @stdin;                     <<01200>>39585000
   x := x + 1;                                                 <<01200>>39590000
   end;                                                        <<01200>>39595000
if stdlist'option then                                         <<01200>>39600000
   begin  << stdlist was specified >>                          <<01200>>39605000
   optnnums(x) := 9;   optns(x) := @stdlist;                   <<01200>>39610000
   x := x + 1;                                                 <<01200>>39615000
   end;                                                        <<01200>>39620000
if string'option then                                          <<01200>>39625000
   begin  << a string to pass was specified >>                 <<01200>>39630000
   optnnums(x) := 11;   optns(x) := @string;                   <<01200>>39635000
   x := x + 1;                                                 <<01200>>39640000
   optnnums(x) := 12;   optns(x) := t'ix;                      <<01200>>39645000
   x := x + 1;                                                 <<01200>>39650000
   end;                                                        <<01200>>39655000
optnnums(x) := 0;     << end of option list >>                 <<01200>>39660000
                                                               <<01200>>39665000
createprocess (error, pin, progname, optnnums, optns);         <<01200>>39670000
                                                               <<01452>>39675000
if < then                                                      <<01452>>39680000
   begin  << process creation failed - determine why >>        <<01452>>39685000
   if error = unknown'prog then                                <<01452>>39690000
      begin  << non-existent program file >>                   <<01452>>39695000
      qualifyfilename (progname, fullfilename);                <<01452>>39700000
      errnum := nosuchprogfile;                                <<01452>>39705000
      parmnum := 1;                                            <<01452>>39710000
      tos := errnum;                                           <<01452>>39715000
      tos := iparms;                                           <<01452>>39720000
      cierr (*, *, 0, @fullfilename);                          <<01452>>39725000
      end                                                      <<01452>>39730000
   else                                                        <<01452>>39735000
      if not createproc'err( error, errnum )  then             <<01452>>39740000
         cierr( errnum := prprnnoload );                       <<01452>>39745000
   end                                                         <<01452>>39750000
else                                                           <<01452>>39755000
   begin  << process creation succeeded >>                     <<01452>>39760000
                                                               <<01452>>39765000
   << check for createprocess warning. >>                      <<01452>>39770000
   if > then createproc'err( -error, errnum );                 <<01452>>39775000
                                                               <<01452>>39780000
   nextline;                                                   <<01452>>39785000
   awake (pin * pcbsize, fatherwait, sonwait);                 <<01452>>39790000
                                                               <<01452>>39795000
   cisubsysfinish (1, errnum, parmnum);                        <<01452>>39800000
   end;                                                        <<01452>>39805000
end;                                                           <<u.rao>>39810000
$control segment = cisubs                                      <<u.rao>>39815000
      procedure cxsegmenter executorhead;                               39820000
      option privileged, uncallable;                                    39825000
      begin                                                             39830000
      comment                                                           39835000
      cxsegmenter is the executor for the segmenter &editor commands    39840000
      ;                                                                 39845000
      entry cxeditor;                                                   39850000
      entry cxvinit;                                           <<rh.pv>>39855000
      byte array prog(0:14),listfile(0:7);                     <<u.rao>>39860000
      logical pin;                                             <<u.rao>>39865000
      integer numparms,flag:=0;                                <<u.rao>>39870000
      double ddl:=[8/";",8/",",8/%15,8/0]d;                    <<u.rao>>39875000
      byte array dl(*)=ddl;                                    <<u.rao>>39880000
      double parms;                                            <<u.rao>>39885000
      byte pointer ppntr=parms;                                <<u.rao>>39890000
      byte sl=parms+1;                                         <<u.rao>>39895000
      integer parmword2=parms+1;                               <<u.rao>>39900000
      logical segflag := false;                                <<u.rao>>39905000
                                                               <<u.rao>>39910000
      move listfile:="SEGLIST ";                               <<u.rao>>39915000
      move prog:="SEGDVR.PUB.SYS ";                            <<u.rao>>39920000
      segflag := true;                                         <<u.rao>>39925000
      go to process;                                           <<u.rao>>39930000
cxvinit:   <<pvinit executor>>                                 <<rh.pv>>39935000
      move listfile := "VINLIST ";                             <<rh.pv>>39940000
      move prog := "PVINIT.PUB.SYS ";                          <<rh.pv>>39945000
      go to process;                                           <<rh.pv>>39950000
cxeditor:                                                      <<u.rao>>39955000
      move listfile:="EDTLIST ";                               <<u.rao>>39960000
      move prog:="EDITOR.PUB.SYS ";                            <<u.rao>>39965000
process:                                                       <<u.rao>>39970000
      mycommand(parmsp,dl,1,numparms,parms);<<check command>>  <<u.rao>>39975000
      if <> then  <<begin -- too many parameters>>             <<u.rao>>39980000
         begin                                                 <<u.rao>>39985000
         errnum := err2mplistonly;  <<only list file allowed>> <<u.rao>>39990000
         parmnum := 2;                                         <<u.rao>>39995000
         tos := errnum;                                        <<u.rao>>40000000
         tos := @ppntr(sl);  <<point to delimiter>>            <<u.rao>>40005000
         tos := dl(parmword2.(14:2));  <<get delimiter>>       <<u.rao>>40010000
         scan * until *,1;                                     <<u.rao>>40015000
         tos := tos+1;                                         <<u.rao>>40020000
         cierr(*,*);                                           <<u.rao>>40025000
         return;                                               <<u.rao>>40030000
         end;                                                  <<u.rao>>40035000
      if numparms <> 0 then                                    <<u.rao>>40040000
         begin<<parameters inputted>>                          <<u.rao>>40045000
         flag:=2;<<set listfile indicator>>                    <<u.rao>>40050000
         errnum := cyimplctfile'(listfile,ppntr,sl);   <<enter <<u.rao>>40055000
         if <> then begin parmnum:=1;return end; <<fatal error<<u.rao>> 40060000
         end;                                                  <<u.rao>>40065000
      setjcw(getjcw land %37777);  <<clear jcw abort bits>>    <<02.mm>>40070000
      tos := tos + 0;<<clear carry>>                           <<u.rao>>40075000
      create(prog,,pin,flag,1); <<create process>>             <<u.rao>>40080000
      if carry then                                            <<u.rao>>40085000
         begin                                                 <<u.rao>>40090000
         delimpfile(flag,listfile); <<delete the file>>        <<u.rao>>40095000
         prog(6) := 0;                                         <<u.rao>>40100000
         if createerror then                                   <<u.rao>>40105000
            cierr(errnum := subsyscreateerr,,0,@prog)          <<u.rao>>40110000
         else                                                  <<u.rao>>40115000
            cierr(errnum := subsysloaderr,,0,@prog);           <<u.rao>>40120000
         return;                                               <<u.rao>>40125000
         end;                                                  <<u.rao>>40130000
      if < then                                                <<u.rao>>40135000
         begin                                                 <<u.rao>>40140000
         delimpfile(flag,listfile);  <<delete file>>           <<u.rao>>40145000
         prog(6) := 0;                                         <<u.rao>>40150000
         cierr(errnum := subsnotfound,,0,@prog);               <<u.rao>>40155000
         return                                                <<u.rao>>40160000
         end;                                                  <<u.rao>>40165000
      awake(pin*pcbsize,1,2); <<start process >>               <<u.rao>>40170000
      delimpfile(flag,listfile); <<delete the file>>           <<u.rao>>40175000
      cisubsysfinish(3, errnum, parmnum);                      <<u.rao>>40180000
      end ; <<cxsegmenter>>                                             40185000
                                                               <<01453>>40190000
procedure cxfcopy executorhead;                                <<01453>>40195000
   option privileged, uncallable;                              <<01453>>40200000
                                                               <<01453>>40205000
<< this procedure creates the fcopy "subsystem" and passes >>  <<01453>>40210000
<< any "INFO" specified with the fcopy command with the    >>  <<01453>>40215000
<< info parameter in the createprocess call.               >>  <<01453>>40220000
                                                               <<01453>>40225000
begin                                                          <<01453>>40230000
                                                               <<01453>>40235000
   array name'(0:6);        << holds name of process.      >>  <<01453>>40240000
   byte array name(*) = name';                                 <<01453>>40245000
   byte pointer tempbp;                                        <<01453>>40250000
   integer pin,                                                <<01453>>40255000
           len,                                                <<01453>>40260000
           error;                                              <<01453>>40265000
   array itemcodes(0:10);                                      <<01453>>40270000
   array items(0:10);                                          <<01453>>40275000
   define unknown'prog'file = ( error = 6 )#;                  <<01453>>40280000
                                                               <<01453>>40285000
   scan parmsp while %6440, 1;                                 <<01453>>40290000
   if carry then   << found nothing but blanks for parms.  >>  <<01453>>40295000
   begin                                                       <<01453>>40300000
      len := 0;                                                <<01453>>40305000
      @tempbp := @parmsp;                                      <<01453>>40310000
      del;                                                     <<01453>>40315000
   end                                                         <<01453>>40320000
   else                                                        <<01453>>40325000
   begin                                                       <<01453>>40330000
      @tempbp := tos;                                          <<01453>>40335000
      scan tempbp until %15, 1;                                <<01453>>40340000
      len := tos - @tempbp;                                    <<01453>>40345000
   end;                                                        <<01453>>40350000
   move name := "FCOPY.PUB.SYS ";                              <<01453>>40355000
                                                               <<01453>>40360000
   move itemcodes := (  3,   << flags                      >>  <<01453>>40365000
                       11,   << info string address.       >>  <<01453>>40370000
                       12,   << info string length.        >>  <<01453>>40375000
                        0  );                                  <<01453>>40380000
                                                               <<01453>>40385000
   items    := 1;                                              <<01453>>40390000
   items(1) := @tempbp;                                        <<01453>>40395000
   items(2) := len;                                            <<01453>>40400000
   items(3) := 0;                                              <<01453>>40405000
                                                               <<01453>>40410000
   setjcw( getjcw land %37777 );                               <<01453>>40415000
   createprocess( error, pin, name, itemcodes, items );        <<01453>>40420000
   if < then                                                   <<01453>>40425000
   begin                                                       <<01453>>40430000
      name(5) := 0;                                            <<01453>>40435000
      if unknown'prog'file then                                <<01453>>40440000
         cierr( errnum := subsnotfound, , 0, @name )           <<01453>>40445000
      else                                                     <<01453>>40450000
      begin                                                    <<01453>>40455000
         createproc'err( error,errnum );                       <<01453>>40460000
         cierr( errnum := subsnotcreate, , 0, @name );         <<01453>>40465000
      end;                                                     <<01453>>40470000
   end                                                         <<01453>>40475000
   else                                                        <<01453>>40480000
   begin                                                       <<01453>>40485000
      if > then createproc'err( -error, errnum );              <<01453>>40490000
      awake( pin * pcbsize, 1, 2 );                            <<01453>>40495000
      cisubsysfinish( 3, errnum, parmnum );                    <<01453>>40500000
   end;                                                        <<01453>>40505000
                                                               <<01453>>40510000
                                                               <<01453>>40515000
end;  << cxfcopy >>                                            <<01453>>40520000
                                                               <<01453>>40525000
                                                               <<01453>>40530000
procedure cxspl executorhead;                                           40535000
   option privileged, uncallable;                                       40540000
begin entry cxsplprep, cxsplgo;                                         40545000
      entry cxfortran, cxfortprep, cxfortgo;                            40550000
      entry cxcobol, cxcobolprep, cxcobolgo;                            40555000
      entry cxbasicomp,cxbasicprep,cxbasicgo;                           40560000
      entry cxrpg,cxrpgprep,cxrpggo;                                    40565000
      entry cxpascal,cxpascalprep,cxpascalgo;                  <<02844>>40570000
      entry cxcobolii, cxcoboliiprep, cxcoboliigo;             <<06130>>40575000
      integer whichflg,x,nextdelim,error,                      <<02844>>40580000
              parmlen,stringlen := 0;                          <<02844>>40585000
      equate maxstringlen = cis'bcombuflen - 12,               << i.a >>40590000
             pkeylistl = 13,                                   <<06130>>40595000
             equals = 1,                                       <<02844>>40600000
             cr = 3;                                           <<02844>>40605000
      define delimtype = (13:3)#,                              <<02844>>40610000
             unknown'prog'file = (error = 6)#;                 <<02844>>40615000
      logical progflag := false;                                        40620000
      byte array splname(0:2) = pb := "SPL";                            40625000
      byte array ftnname(0:2) = pb := "FTN";                            40630000
      byte array cobname(0:2) = pb := "COB";                            40635000
      byte array bscname(0:2) = pb := "BSC";                            40640000
      byte array rpgname(0:2) = pb := "RPG";                            40645000
      byte array pascname(0:2) = pb := "PAS";                  <<02844>>40650000
      byte array text(0:4) = pb := "TEXT ";                             40655000
      byte array list(0:4) = pb := "LIST ";                             40660000
      byte array usl(0:3) = pb := "USL ";                               40665000
      byte array prog(0:35);                                  <<a01.01>>40670000
      byte array mast(0:4) = pb := "MAST ";                             40675000
      byte array new(0:3)  = pb := "NEW ";                              40680000
      byte array sysfilename(0:16);                                     40685000
      byte array buildname(0:8);                               <<02844>>40690000
      integer numparms,maxparms := 6;                          <<02844>>40695000
      integer array optnums(0:12);                             <<02844>>40700000
      logical array optns(0:12);                               <<02844>>40705000
      double array parms(0:maxstringlen);                      <<02844>>40710000
      lbparmdecs;                                                       40715000
      logical comcr := %26015;                                          40720000
      byte pointer fname,sptr,parmptr;                         <<02844>>40725000
      logical t2,t3;                                           <<u.rao>>40730000
      logical parm := 0;                                                40735000
      logical pin,stop,scan'stop'test := %6400,info := false;  <<02844>>40740000
      logical wkspfound := false; << flag for wksp found >>    <<06130>>40745000
      integer pcnt := 0;                                                40750000
      switch uslproglist := us,pr,lt;                                   40755000
      byte array string(0:maxstringlen - 1);                   << i.a >>40760000
      byte array savedcomimage(0:cis'bcombuflen - 1);          << i.a >>40765000
      byte array pkeylist(0:pkeylistl - 1) = pb :=             <<02844>>40770000
         6,4,"INFO",                                           <<02844>>40775000
         6,4,"WKSP",                                           <<06130>>40780000
         0;                                                    <<02844>>40785000
      byte array keylist(0:pkeylistl - 1);                     <<02844>>40790000
define checksegerr =                                           <<u.rao>>40795000
   if <> and (t2<>1) then   <<warning was printed>>            <<u.rao>>40800000
      begin                                                    <<u.rao>>40805000
      segmenter(pin,8,t3);  <<exit segmenter>>                 <<u.rao>>40810000
      parmnum := t2;                                           <<u.rao>>40815000
      delimpfile(parm,buildname);                              <<u.rao>>40820000
      cierr(errnum := segmentererror);                         <<u.rao>>40825000
      return;                                                  <<u.rao>>40830000
      end#;                                                    <<u.rao>>40835000
                                                               <<u.rao>>40840000
<< ======================================================== >> <<06130>>40845000
<< =====                                              ===== >> <<06130>>40850000
<< =====        subroutine bldimpfile                 ===== >> <<06130>>40855000
<< =====                                              ===== >> <<06130>>40860000
<< ======================================================== >> <<06130>>40865000
                                                               <<06130>>40870000
subroutine bldimpfile;                                         <<u.rao>>40875000
begin                                                          <<u.rao>>40880000
errnum := cyimplctfile'(buildname,fname,t3);                   <<u.rao>>40885000
if <> then  <<error occurred>>                                 <<u.rao>>40890000
   begin                                                       <<u.rao>>40895000
   delimpfile(parm,buildname);                                 <<u.rao>>40900000
   parmnum := pcnt+1;                                          <<u.rao>>40905000
   assemble(exit 3);                                           <<u.rao>>40910000
   end;                                                        <<u.rao>>40915000
end;                                                           <<u.rao>>40920000
                                                               <<06130>>40925000
<< ======================================================== >> <<06130>>40930000
<< =====                                              ===== >> <<06130>>40935000
<< =====           subroutine getnext                 ===== >> <<06130>>40940000
<< =====                                              ===== >> <<06130>>40945000
<< ======================================================== >> <<06130>>40950000
                                                               <<06130>>40955000
subroutine getnext;                                            <<02844>>40960000
<< sets parmptr to current parameter, gets parameter length >> <<02844>>40965000
<< establishes the delimiter type, and advances parameter   >> <<02844>>40970000
<< count.                                                   >> <<02844>>40975000
   begin                                                       <<02844>>40980000
   tos := parms(parmnum);                                      <<02844>>40985000
   nextdelim := s0.delimtype;                                  <<02844>>40990000
   parmlen := tos&lsr(8);                                      <<02844>>40995000
   @parmptr := logical(tos);                                   <<02844>>41000000
   parmnum := parmnum + 1;                                     <<02844>>41005000
   end; << getnext >>                                          <<02844>>41010000
                                                               <<06130>>41015000
<< ======================================================== >> <<06130>>41020000
<< =====                                              ===== >> <<06130>>41025000
<< =====        subroutine procinfo                   ===== >> <<06130>>41030000
<< =====                                              ===== >> <<06130>>41035000
<< ======================================================== >> <<06130>>41040000
                                                               <<06130>>41045000
logical subroutine procinfo;                                   <<02844>>41050000
<< processing for the info parameter >>                                 41055000
   begin                                                       <<02844>>41060000
   procinfo := false;                                          <<02844>>41065000
   if nextdelim <> equals then                                 <<02844>>41070000
      begin                                                    <<02844>>41075000
      cierr(errnum := reqequalsign,parmptr);                   <<02844>>41080000
      return;                                                  <<02844>>41085000
      end;                                                     <<02844>>41090000
   if info then << specified more than once >>                 <<02844>>41095000
      cierr(errnum := -infooveride,parmptr);                   <<02844>>41100000
   info := true;                                               <<02844>>41105000
   stringlen := 0;                                             <<02844>>41110000
   getnext;                                                    <<02844>>41115000
   if parmptr <> """" and parmptr <> "'" then                  <<02844>>41120000
      begin                                                    <<02844>>41125000
      cierr(errnum := expctquote,parmptr);                     <<02844>>41130000
      return;                                                  <<02844>>41135000
      end;                                                     <<02844>>41140000
   scan'stop'test.(8:8) := parmptr; << set up word for scan >> <<02844>>41145000
   << set up sptr to point into the string copy, >>            <<02844>>41150000
   << because mycommand upshifts.                >>            <<02844>>41155000
   x := logical(@parmptr) - logical(@cis'bcomimage) + 1;       << i.a >>41160000
   @sptr := logical(@savedcomimage(x));                        <<02844>>41165000
   stop := false;                                              <<02844>>41170000
   while not stop do                                           <<02844>>41175000
      begin                                                    <<02844>>41180000
      scan sptr until scan'stop'test,1;                        <<02844>>41185000
      if carry then << missing closing quote, found cr >>      <<02844>>41190000
         begin                                                 <<02844>>41195000
         x := tos - logical(@savedcomimage);                   <<02844>>41200000
         @parmptr := logical(@cis'bcomimage(x));               << i.a >>41205000
         cierr(errnum := expctclosequote,parmptr);             <<02844>>41210000
         stop := true;                                         <<02844>>41215000
         end                                                   <<02844>>41220000
      else                                                     <<02844>>41225000
         begin                                                 <<02844>>41230000
         x := ls0 - logical(@sptr);                            <<02844>>41235000
         @sptr := logical(tos);                                <<02844>>41240000
         if sptr = sptr(1) then << found double qoute >>       <<02844>>41245000
            begin                                              <<02844>>41250000
            x := x + 1;                                        <<02844>>41255000
            @sptr := logical(@sptr) + 1;                       <<02844>>41260000
            end                                                <<02844>>41265000
         else << found closing quote >>                        <<02844>>41270000
            stop := true;                                      <<02844>>41275000
         << move into string, note that if we had >>           <<02844>>41280000
         << a double qoute, one is moved in.      >>           <<02844>>41285000
         move string(stringlen) := sptr(-x),(x);               <<02844>>41290000
         stringlen := stringlen + x;                           <<02844>>41295000
         << set sptr to next character after    >>             <<02844>>41300000
         << quote or double quote.              >>             <<02844>>41305000
         @sptr := logical(@sptr) + 1;                          <<02844>>41310000
         end;                                                  <<02844>>41315000
      end; << while loop >>                                    <<02844>>41320000
   << since string can contain delimiters and    >>            <<02844>>41325000
   << mycommand will parse them, advance parmptr >>            <<02844>>41330000
   << to the right place.                        >>            <<02844>>41335000
   x := stringlen;                                             <<02844>>41340000
   while (x := x - 1) >= 0 do                                  <<02844>>41345000
      if string(x) = ";" or string(x) = "," or                 <<02844>>41350000
         string(x) = "=" then                                  <<02844>>41355000
         getnext;                                              <<02844>>41360000
   << check for extra chars. between closing qoute >>          <<02844>>41365000
   << and next delimiter which can be semi or cr.  >>          <<02844>>41370000
   if errnum <= 0 then                                         <<02844>>41375000
      begin                                                    <<02844>>41380000
      scan sptr while %6440,1;                                 <<02844>>41385000
      if carry then << found cr >>                             <<02844>>41390000
         del                                                   <<02844>>41395000
      else                                                     <<02844>>41400000
         begin                                                 <<02844>>41405000
         if bps0 <> ";" then                                   <<02844>>41410000
            begin                                              <<02844>>41415000
            x := tos - logical(@savedcomimage);                <<02844>>41420000
            @parmptr := logical(@cis'bcomimage(x));            << i.a >>41425000
            cierr(errnum := xpctsemiorcr,parmptr);             <<02844>>41430000
            end                                                <<02844>>41435000
         else                                                  <<02844>>41440000
            del;                                               <<02844>>41445000
         end;                                                  <<02844>>41450000
      end;                                                     <<02844>>41455000
   if errnum <= 0 then                                         <<02844>>41460000
      procinfo := true;                                        <<02844>>41465000
   end; << procinfo >>                                         <<02844>>41470000
                                                               <<06130>>41475000
<< ======================================================== >> <<06130>>41480000
<< =====                                              ===== >> <<06130>>41485000
<< =====        subroutine wksp                       ===== >> <<06130>>41490000
<< =====                                              ===== >> <<06130>>41495000
<< ======================================================== >> <<06130>>41500000
                                                               <<06130>>41505000
                                                               <<06130>>41510000
logical subroutine wksp;                                       <<06130>>41515000
                                                               <<06130>>41520000
<<  this routine parses the wksp parameter. the syntax is:  >> <<06130>>41525000
<<           wksp = wkspfilename                            >> <<06130>>41530000
<<                                                          >> <<06130>>41535000
<<  we build a file equation for xxxxwksp and set bit 10 of >> <<06130>>41540000
<<  the parm word. true is returned only if successful.     >> <<06130>>41545000
<<                                                          >> <<06130>>41550000
<<  parmptr should be pointing to the wksp keyword.         >> <<06130>>41555000
<<  parmnum references the wkspfilename paramter.           >> <<06130>>41560000
                                                               <<06130>>41565000
begin                                                          <<06130>>41570000
   wksp := false; << return true only if everything is good >> <<06130>>41575000
   if nextdelim <> equals                                      <<06130>>41580000
   then begin                                                  <<06130>>41585000
      cierr(errnum := reqequalsign,  parmptr);                 <<06130>>41590000
      return;                                                  <<06130>>41595000
   end;                                                        <<06130>>41600000
                                                               <<06130>>41605000
   if wkspfound                                                <<06130>>41610000
   then begin  << we've been here before >>                    <<06130>>41615000
      cierr(errnum := wkspalreadyfnd, parmptr);                <<06130>>41620000
      return;                                                  <<06130>>41625000
   end;                                                        <<06130>>41630000
                                                               <<06130>>41635000
   wkspfound := true;  << yes, we are here >>                  <<06130>>41640000
                                                               <<06130>>41645000
   if not cibadfilename(errnum, parms(parmnum))                <<06130>>41650000
   then begin  << all's well >>                                <<06130>>41655000
      @fname := lparm(parmnum*2); << pointer to file name >>   <<06130>>41660000
      move buildname(3) := "WKSP ";<< xxxxwksp >>              <<06130>>41665000
      t3 := bparm(parmnum*4+2); << length of filename >>       <<06130>>41670000
      << ........................................... >>        <<06130>>41675000
      << the above three variables are parameters to >>        <<06130>>41680000
      << cyimplctfile' which bldimpfile calls.       >>        <<06130>>41685000
      << ........................................... >>        <<06130>>41690000
                                                               <<06130>>41695000
      bldimpfile;                                              <<06130>>41700000
                                                               <<06130>>41705000
      getnext; << all done with wksp >>                        <<06130>>41710000
      parm := parm lor %40;<< set bit 10 for the compilers >>  <<06130>>41715000
      wksp := true; << successful return >>                    <<06130>>41720000
   end;                                                        <<06130>>41725000
                                                               <<06130>>41730000
end;  <<  wksp  >>                                             <<06130>>41735000
                                                               <<06130>>41740000
                                                               <<06130>>41745000
<< ======================================================== >> <<06130>>41750000
<< =====                                              ===== >> <<06130>>41755000
<< =====        cxspl main program                    ===== >> <<06130>>41760000
<< =====                                              ===== >> <<06130>>41765000
<< ======================================================== >> <<06130>>41770000
                                                               <<06130>>41775000
      tos := 0;                                                         41780000
      go to prespl;                                                     41785000
cxsplprep:                                                              41790000
      tos := 1;                                                         41795000
      go to prespl;                                                     41800000
cxsplgo:                                                                41805000
      tos := 2;                                                         41810000
prespl:                                                                 41815000
      move sysfilename := "SPL.PUB.SYS ";                               41820000
      move buildname := splname , (3);                                  41825000
      go to process;                                                    41830000
cxrpg:                                                                  41835000
      tos:=0;                                                           41840000
      go to prerpg;                                                     41845000
cxrpgprep:                                                              41850000
      tos:=1;                                                           41855000
      go to prerpg;                                                     41860000
cxrpggo:                                                                41865000
      tos:=2;                                                           41870000
prerpg:                                                                 41875000
      move sysfilename:="RPG.PUB.SYS ";                                 41880000
      move buildname:=rpgname,(3);                                      41885000
      go to process;                                                    41890000
cxfortran:                                                              41895000
      tos := 0;                                                         41900000
      go to prefort;                                                    41905000
cxfortprep:                                                             41910000
      tos := 1;                                                         41915000
      go to prefort;                                                    41920000
cxfortgo:                                                               41925000
      tos := 2;                                                         41930000
prefort:                                                                41935000
      move sysfilename := "FORTRAN.PUB.SYS ";                           41940000
      move buildname := ftnname , (3);                                  41945000
      go to process;                                                    41950000
cxbasicomp:                                                             41955000
      tos:=0;                                                           41960000
      go to prebsc;                                                     41965000
cxbasicprep:                                                            41970000
      tos:=1;                                                           41975000
      go to prebsc;                                                     41980000
cxbasicgo:                                                              41985000
      tos:=2;                                                           41990000
prebsc:                                                                 41995000
      move sysfilename:="BASICOMP.PUB.SYS ";                            42000000
      move buildname:=bscname,(3);                                      42005000
      maxparms := 4;  <<basic compiler has no new or master>>  <<u.rao>>42010000
      go to process;                                                    42015000
cxcobol:                                                                42020000
      tos := 0;                                                         42025000
      go to precob;                                                     42030000
cxcobolprep:                                                            42035000
      tos := 1;                                                         42040000
      go to precob;                                                     42045000
cxcobolgo:                                                              42050000
      tos := 2;                                                         42055000
precob:                                                                 42060000
      move sysfilename := "COBOL.PUB.SYS ";                             42065000
      move buildname := cobname , (3);                                  42070000
      go to process;                                           <<02844>>42075000
cxcobolii:                                                     <<06130>>42080000
      tos := 0;                                                <<06130>>42085000
      go to precobii;                                          <<06130>>42090000
cxcoboliiprep:                                                 <<06130>>42095000
      tos := 1;                                                <<06130>>42100000
      go to precobii;                                          <<06130>>42105000
cxcoboliigo:                                                   <<06130>>42110000
      tos := 2;                                                <<06130>>42115000
                                                               <<06130>>42120000
precobii:                                                      <<06130>>42125000
      move sysfilename := "COBOLII.PUB.SYS ";                  <<06130>>42130000
      move buildname   := cobname, (3);                        <<06130>>42135000
      go to process;                                           <<06130>>42140000
cxpascal:                                                      <<02844>>42145000
      tos := 0;                                                <<02844>>42150000
      go to prepasc;                                           <<02844>>42155000
cxpascalprep:                                                  <<02844>>42160000
      tos := 1;                                                <<02844>>42165000
      go to prepasc;                                           <<02844>>42170000
cxpascalgo:                                                    <<02844>>42175000
      tos := 2;                                                <<02844>>42180000
prepasc:                                                       <<02844>>42185000
      move sysfilename := "PASCAL.PUB.SYS ";                   <<02844>>42190000
      move buildname := pascname,(3);                          <<02844>>42195000
      maxparms := 4; << no new, no master >>                   <<02844>>42200000
process:                                                                42205000
      whichflg := tos;                                                  42210000
      << check for parameters, semi marks start >>             <<02844>>42215000
      << keywords and positional parameters are >>             <<02844>>42220000
      << parsed separately.                     >>             <<02844>>42225000
      scan parmsp until %6473,1; << cr,semicolon >>            <<02844>>42230000
      if carry then                                            <<02844>>42235000
         del                                                   <<02844>>42240000
      else                                                     <<02844>>42245000
         begin << found keyword >>                             <<02844>>42250000
         bps0 := %15;                                          <<02844>>42255000
         @sptr := logical(tos) + 1;                            <<02844>>42260000
         move keylist := pkeylist,(pkeylistl);                 <<02844>>42265000
         << save string's original form >>                     <<02844>>42270000
         move savedcomimage := cis'bcomimage,(cis'bcombuflen); << i.a >>42275000
         mycommand(sptr,,maxstringlen + 1,numparms,parms);     <<02844>>42280000
         if carry then << too many parameters in string >>     <<02844>>42285000
            begin                                              <<02844>>42290000
            cierr(errnum := paramtoobig);                      <<02844>>42295000
            return;                                            <<02844>>42300000
            end;                                               <<02844>>42305000
         if numparms = 0 then                                  <<02844>>42310000
            cierr(-extrndelimignrd,sptr)                       <<02844>>42315000
         else                                                  <<02844>>42320000
         do << loop on keywords >>                             <<02844>>42325000
            begin                                              <<02844>>42330000
            getnext;                                           <<02844>>42335000
            if parmlen = 0 then                                <<02844>>42340000
               cierr(errnum := -extrndelimignrd,parmptr)       <<02844>>42345000
            else                                               <<02844>>42350000
               begin                                           <<02844>>42355000
               tos := search(parmptr,parmlen,keylist);         <<02844>>42360000
               case *tos of                                    <<02844>>42365000
                  begin                                        <<02844>>42370000
                  << 0 >> << no such keyword >>                <<02844>>42375000
                  begin                                        <<02844>>42380000
                  cierr(errnum := unknwnkwrd,parmptr);         <<02844>>42385000
                  return;                                      <<02844>>42390000
                  end;                                         <<02844>>42395000
                  << 1 >> << info >>                           <<02844>>42400000
                  if not procinfo then                         <<02844>>42405000
                     return;                                   <<02844>>42410000
                  << 2 >>  << wksp >>                          <<06130>>42415000
                  if not wksp  then                            <<06130>>42420000
                     return;  << error >>                      <<06130>>42425000
                  end; << case >>                              <<02844>>42430000
               end;                                            <<02844>>42435000
            end                                                <<02844>>42440000
         until nextdelim = cr                                  <<02844>>42445000
         end;                                                  <<02844>>42450000
      t3 := 1;                                                          42455000
      if whichflg=2 then maxparms := maxparms-1; <<xxxgo>>     <<u.rao>>42460000
      mycommand(parmsp,comcr,maxparms,numparms,parms);                  42465000
      if numparms = maxparms then   <<too many parameters>>    <<u.rao>>42470000
         begin                                                 <<u.rao>>42475000
         parmnum := maxparms;                                  <<u.rao>>42480000
         tos := errnum := subs2mp;                             <<u.rao>>42485000
         tos := parms(maxparms-1);                             <<u.rao>>42490000
         del;                                                  <<u.rao>>42495000
         cierr(*,*,%10000,maxparms-1);                         <<u.rao>>42500000
         return;                                               <<u.rao>>42505000
         end;                                                  <<u.rao>>42510000
      if numparms = 0 then go to doit;                                  42515000
      if (t3 := bparm(2)) = 0 then go to next;                          42520000
      @fname := lparm;                                                  42525000
      move buildname(3) := text , (5);                                  42530000
      bldimpfile;                                              <<u.rao>>42535000
      parm := parm + 1;                                                 42540000
next:                                                                   42545000
      pcnt := pcnt + 1;                                                 42550000
      if numparms = 1 then go to doit;                                  42555000
      if (t3 := bparm (6)) = 0 then                                     42560000
         if whichflg = 2 then goto next2                                42565000
         else goto next1;                                               42570000
      @fname := lparm(2);                                               42575000
      tos := @buildname(3);                                             42580000
      go to uslproglist(whichflg);                                      42585000
us:   tos := @usl;                                                      42590000
      parm := parm + 4;                                                 42595000
      tos := 4;                                                         42600000
      go to pack;                                                       42605000
pr:     <<program file name>>                                 <<a01.01>>42610000
      if cibadfilename(errnum,parms(1)) then                   <<u.rao>>42615000
         begin  <<progfile name is bad>>                       <<u.rao>>42620000
         parmnum := 2;                                         <<u.rao>>42625000
         return                                                <<u.rao>>42630000
         end;                                                  <<u.rao>>42635000
      prog := " ";                                            <<a01.01>>42640000
      move prog(1) := prog,(35);                              <<a01.01>>42645000
      tos := @prog;                                           <<a01.01>>42650000
      tos := parms(1)&lsr(8);  <<stack address and length>>   <<a01.01>>42655000
      move * := *,(tos);                                      <<a01.01>>42660000
      progflag := true;                                                 42665000
      goto next1;                                                       42670000
pack:                                                                   42675000
      assemble(mvb pb);                                                 42680000
      bldimpfile;                                              <<u.rao>>42685000
next1:                                                                  42690000
      pcnt := pcnt + 1;                                                 42695000
      if numparms = 2 then go to doit;                                  42700000
      if (t3 := bparm(10)) = 0 then go to next2;                        42705000
      @fname := lparm(4);                                               42710000
      tos := @buildname(3);                                             42715000
lt:   tos := @list;                                                     42720000
      tos := 5;                                                         42725000
      assemble(mvb pb);                                                 42730000
      bldimpfile;                                              <<u.rao>>42735000
      parm := parm + 2;                                                 42740000
next2:                                                                  42745000
      pcnt := pcnt + 1;                                                 42750000
      if numparms = pcnt then go to doit;                               42755000
      if (t3 := bparm(4*pcnt + 2))= 0 then go to next3;                 42760000
      @fname := lparm(2*pcnt);                                          42765000
      move buildname(3) := mast ,(5);                                   42770000
      bldimpfile;                                              <<u.rao>>42775000
      parm := parm lor %10;                                             42780000
next3:                                                                  42785000
      pcnt := pcnt + 1;                                                 42790000
      if numparms = pcnt then go to doit;                               42795000
      if (t3 := bparm(4*pcnt+2)) = 0 then go to doit;          <<u.rao>>42800000
      @fname := lparm(2*pcnt);                                          42805000
      move buildname(3) := new , (4);                                   42810000
      bldimpfile;                                              <<u.rao>>42815000
      parm := parm lor %20;                                             42820000
doit:                                                                   42825000
      setjcw(getjcw land %37777);  <<clear jcw abort bits>>    <<02.mm>>42830000
      optnums(0) := 3; optns(0) := 1; << flags >>              <<02844>>42835000
      optnums(1) := 2; optns(1) := parm; << parm word >>       <<02844>>42840000
      x := 1;                                                  <<02844>>42845000
      if info then                                             <<02844>>42850000
         begin                                                 <<02844>>42855000
         optnums(x := x + 1) := 11;                            <<02844>>42860000
         optns(x) := @string;                                  <<02844>>42865000
         optnums(x := x + 1) := 12;                            <<02844>>42870000
         optns(x) := stringlen;                                <<02844>>42875000
         end;                                                  <<02844>>42880000
      optnums(x := x + 1) := 0;                                <<02844>>42885000
      optns(x) := 0;                                           <<02844>>42890000
      createprocess(error,pin,sysfilename,optnums,optns);      <<02844>>42895000
      if < then                                                <<02844>>42900000
      begin                                                    <<u.rao>>42905000
         delimpfile(parm,buildname);                           <<u.rao>>42910000
         scan sysfilename until "..",1;                        <<u.rao>>42915000
         bps0 := 0;                                            <<u.rao>>42920000
         del;                                                  <<u.rao>>42925000
         if unknown'prog'file then                             <<02844>>42930000
            cierr(errnum :=subsnotfound,,0,@sysfilename)       <<02844>>42935000
         else                                                  <<02844>>42940000
            begin                                              <<02844>>42945000
            createproc'err(error,errnum);                      <<02844>>42950000
            cierr(errnum := subsnotcreate,,0,@sysfilename);    <<02844>>42955000
            end;                                               <<02844>>42960000
         return;                                               <<u.rao>>42965000
      end;                                                              42970000
      if > then                                                <<02844>>42975000
         createproc'err(-error,errnum);                        <<02844>>42980000
      nextline;                                                         42985000
      awake(pin*pcbsize,1,2);                                           42990000
      if whichflg = 0 then                                              42995000
         begin    <<just compile>>                                      43000000
         delimpfile(parm,buildname);                           <<u.rao>>43005000
         cisubsysfinish(4, errnum, parmnum);                   <<u.rao>>43010000
         return;                                               <<u.rao>>43015000
         end;                                                           43020000
      if not cisubsysfinish(4, errnum, parmnum) then           <<u.rao>>43025000
         begin    <<error in compile of multi-step>>                    43030000
         delimpfile(parm,buildname);                           <<u.rao>>43035000
         cierr(errnum := compfailednoprp);                     <<u.rao>>43040000
         return;                                               <<u.rao>>43045000
         end;                                                           43050000
      pin := 0;                                                         43055000
      move sysfilename := "$OLDPASS ";                                  43060000
      segmenter(pin,22,t2,,,,,,,,,sysfilename);                <<00629>>43065000
      checksegerr;                                             <<u.rao>>43070000
      if (whichflg = 2)  or not (progflag)  then                        43075000
         move prog := "$NEWPASS ";                                      43080000
      segmenter (pin, 14, t2, -1, -1, 0, -1, 0, -1, , , prog); <<00629>>43085000
      checksegerr;                                             <<u.rao>>43090000
      segmenter (pin, 8, t2);                                           43095000
      delimpfile(parm,buildname);                              <<u.rao>>43100000
      if whichflg = 1 then   <<just compile & prep>>           <<u.rao>>43105000
         begin                                                 <<u.rao>>43110000
         cisubsysfinish(2, errnum, parmnum);                   <<u.rao>>43115000
         return                                                <<u.rao>>43120000
         end;                                                  <<u.rao>>43125000
      if not cisubsysfinish(2, errnum, parmnum) then           <<u.rao>>43130000
         begin                                                 <<u.rao>>43135000
         cierr(errnum := prepfailednorun);                     <<u.rao>>43140000
         return;                                               <<u.rao>>43145000
         end;                                                  <<u.rao>>43150000
      tos := tos + 0;            <<clear carry>>                        43155000
      create(sysfilename,,pin,,1);                                      43160000
      if carry then   <<create failed>>                        <<u.rao>>43165000
         begin                                                 <<u.rao>>43170000
         if createerror then                                   <<u.rao>>43175000
            cierr(errnum := compiledcreate)                    <<u.rao>>43180000
         else                                                  <<u.rao>>43185000
            cierr(errnum := compiledload);                     <<u.rao>>43190000
         return                                                <<u.rao>>43195000
         end;                                                  <<u.rao>>43200000
      if < then                                                <<u.rao>>43205000
         begin                                                 <<u.rao>>43210000
         cierr(errnum := invalidprogfile);                     <<u.rao>>43215000
         return                                                <<u.rao>>43220000
         end;                                                  <<u.rao>>43225000
      if > then cierr(errnum := -defval);                      <<04785>>43230000
      nextline;                                                         43235000
      awake(pin*pcbsize,1,2);                                           43240000
      cisubsysfinish(1, errnum, parmnum);                      <<u.rao>>43245000
end;  <<cxspl et al>>                                          <<u.rao>>43250000
procedure cxbasic executorhead;                                         43255000
   option privileged, uncallable;                                       43260000
begin logical x1 := %26015;                                             43265000
      integer numparms;                                                 43270000
      double array parms(0:3);                                 <<u.rao>>43275000
      lbparmdecs;                                                       43280000
      byte array basinpt(0:6) = pb := "BASIN ";                         43285000
      byte array blist(0:7) = pb := "BASLIST ";                         43290000
      byte array bcom (0:6) = pb := "BASCOM ";                          43295000
      byte array fname(0:7);                                            43300000
      byte pointer fref;                                                43305000
      logical t3;                                              <<u.rao>>43310000
      logical pin , parm := 0;                                          43315000
      byte array sysfilename(0:14);                                     43320000
      byte blank := " ";                                                43325000
      integer pcnt := 1;                                                43330000
subroutine cleanup;                                                     43335000
begin                                                                   43340000
      tos := parm;                                                      43345000
      if < then                                                         43350000
      begin move fname := bcom , (7);                                   43355000
            xremjtentry(fname,blank,blank,3)                            43360000
      end;                                                              43365000
      assemble(tbc 1);                                                  43370000
      if <> then                                                        43375000
      begin move fname := basinpt , (7);                                43380000
            xremjtentry(fname,blank,blank,3)                            43385000
      end;                                                              43390000
      delimpfile(*,fname);                                              43395000
end;                                                                    43400000
                                                               <<u.rao>>43405000
subroutine bldimpfile;                                         <<u.rao>>43410000
begin                                                          <<u.rao>>43415000
errnum := cyimplctfile'(fname,fref,t3);                        <<u.rao>>43420000
if <> then  <<error occurred>>                                 <<u.rao>>43425000
   begin                                                       <<u.rao>>43430000
   cleanup;                                                    <<u.rao>>43435000
   parmnum := pcnt;                                            <<u.rao>>43440000
   assemble(exit 3);                                           <<u.rao>>43445000
   end;                                                        <<u.rao>>43450000
end;                                                           <<u.rao>>43455000
                                                               <<u.rao>>43460000
      move sysfilename := "BASIC.PUB.SYS ";                             43465000
      t3 := 1;                                                          43470000
      mycommand(parmsp,x1,4,numparms,parms);                   <<u.rao>>43475000
      if numparms >= 4 then  <<t00 many parameters>>           <<u.rao>>43480000
         begin                                                 <<u.rao>>43485000
         parmnum := 4;                                         <<u.rao>>43490000
         tos := errnum := subs2mp;                             <<u.rao>>43495000
         tos := lparm(6);                                      <<u.rao>>43500000
         cierr(*,*,%10000,3);                                  <<u.rao>>43505000
         return;                                               <<u.rao>>43510000
         end;                                                  <<u.rao>>43515000
      if numparms = 0 then go to doit;                                  43520000
      if (t3 := bparm(2)) = 0 then go to tfile;                         43525000
      move fname := bcom , (7);                                         43530000
      @fref := lparm;                                                   43535000
      bldimpfile;                                              <<u.rao>>43540000
      parm.(0:1) := 1;   <<command file present>>              <<u.rao>>43545000
tfile:                                                                  43550000
      if numparms = 1 then go to doit;                                  43555000
      pcnt := pcnt + 1;                                                 43560000
      if (t3 := bparm(6)) = 0 then go to lfile;                         43565000
      move fname := basinpt , (7);                                      43570000
      @fref := lparm(2);                                                43575000
      bldimpfile;                                              <<u.rao>>43580000
      parm.(1:1) := 1;  <<basic input file present>>           <<u.rao>>43585000
lfile:                                                                  43590000
      if numparms = 2 then go to doit;                                  43595000
      pcnt := pcnt + 1;                                                 43600000
      if (t3 := bparm(10)) = 0 then go to doit;                <<u.rao>>43605000
      move fname := blist , (8);                                        43610000
      @fref := lparm(4);                                                43615000
      bldimpfile;                                              <<u.rao>>43620000
      parm := parm + 2;                                                 43625000
doit:                                                                   43630000
      setjcw(getjcw land %37777);  <<clear jcw abort bits>>    <<02.mm>>43635000
      tos := tos + 0;            <<clear carry>>                        43640000
      create(sysfilename,,pin,parm,1);                                  43645000
      if carry then                                                     43650000
      begin cleanup;                                                    43655000
            if createerror then                                <<u.rao>>43660000
               cierr(errnum := basiccreateerr)                 <<u.rao>>43665000
            else                                               <<u.rao>>43670000
               cierr(errnum := basicloaderr);                  <<u.rao>>43675000
            return;                                            <<u.rao>>43680000
      end;                                                              43685000
      if < then                                                         43690000
      begin cleanup;                                                    43695000
         sysfilename(5) := 0;                                  <<u.rao>>43700000
         cierr(errnum := subsnotfound,,0,@sysfilename);        <<u.rao>>43705000
         return;                                               <<u.rao>>43710000
      end;                                                              43715000
      nextline;                                                         43720000
      awake(pin*pcbsize,1,2);                                           43725000
                                                                        43730000
      cleanup;                                                          43735000
      cisubsysfinish(3, errnum, parmnum);                      <<u.rao>>43740000
end;  <<cxbasic>>                                              <<u.rao>>43745000
$control segment = cipreprun                                   <<u.rao>>43750000
procedure cxapl executorhead;                                 <<a00.04>>43755000
   option privileged, uncallable;                             <<a00.04>>43760000
begin                                                         <<a00.04>>43765000
byte array sysfilename(0:11);                                 <<a00.04>>43770000
double array parms(0:1) = q;  <<for mycommand results>>        <<02.ro>>43775000
byte pointer aplwsfname = parms;  <<name of workspace>>        <<02.ro>>43780000
byte wsfnamelen = parms+1;                                     <<02.ro>>43785000
byte pointer extraparm = parms+2; <<extraneous parm>>          <<02.ro>>43790000
integer numparms;                                              <<02.ro>>43795000
logical pin;  <<pin of created apl process>>                   <<02.ro>>43800000
byte array formaldes(0:5);  << "APLWS ">>                      <<02.ro>>43805000
                                                               <<02.ro>>43810000
mycommand(parmsp, , 2, numparms, parms);                       <<02.ro>>43815000
if numparms >= 2 then  <<too many parms>>                      <<02.ro>>43820000
   begin                                                       <<02.ro>>43825000
   parmnum := 2;                                               <<02.ro>>43830000
   cierr(errnum := aplxpctjustws, extraparm);                  <<02.ro>>43835000
   end                                                         <<02.ro>>43840000
else   <<legal number of parms>>                               <<02.ro>>43845000
   begin                                                       <<02.ro>>43850000
   if numparms = 1 then  <<set up file equate>>                <<02.ro>>43855000
      begin                                                    <<02.ro>>43860000
      parmnum.(7:1) := 1;  <<set flag for apl>>                <<02.ro>>43865000
      move formaldes := "APLWS ";                              <<02.ro>>43870000
      errnum := cyimplctfile'(formaldes, aplwsfname,           <<02.ro>>43875000
                    wsfnamelen);  <<do equate>>                <<02.ro>>43880000
      if <> then parmnum := 1;  <<name problem>>               <<02.ro>>43885000
      end;  <<handling of file name, if any>>                  <<02.ro>>43890000
   if errnum = 0 then  <<good so far, try launch>>            <<02.ro>>43895000
      begin                                                    <<02.ro>>43900000
      move sysfilename := "APL.PUB.SYS ";                      <<02.ro>>43905000
      setjcw(getjcw land %37777);  <<clear jcw abort bits>>    <<02.mm>>43910000
      create(sysfilename, , pin, parmnum, 1);                  <<02.ro>>43915000
      if carry then   <<create failed>>                        <<02.ro>>43920000
         begin                                                 <<02.ro>>43925000
         sysfilename(3) := 0;                                  <<02.ro>>43930000
         if createerror then                                   <<02.ro>>43935000
            cierr(errnum := subsyscreateerr,,0,@sysfilename)   <<02.ro>>43940000
         else   <<loader error>>                               <<02.ro>>43945000
            cierr(errnum := subsysloaderr,,0,@sysfilename);    <<02.ro>>43950000
         end                                                   <<02.ro>>43955000
      else if < then  <<apl.pub.sys not found>>                <<02.ro>>43960000
         begin                                                 <<02.ro>>43965000
         sysfilename(3) := 0;                                  <<02.ro>>43970000
         cierr(errnum := subsnotfound,,0,@sysfilename);        <<02.ro>>43975000
         end                                                   <<02.ro>>43980000
      else   <<create went f	ine>>                             <<02.ro>>43985000
         begin                                                 <<02.ro>>43990000
         awake(pin*pcbsize, 1, 2);  <<fire up subsystem>>      <<02.ro>>43995000
         cisubsysfinish(0, errnum, parmnum);                   <<02.ro>>44000000
         end;                                                  <<02.ro>>44005000
      end;                                                     <<02.ro>>44010000
   end;                                                        <<02.ro>>44015000
end;   <<cxapl>>                                               <<02.ro>>44020000
procedure apltranslateout(message,length,transtype);          <<a00.04>>44025000
  value length,transtype;                                     <<a00.04>>44030000
  integer length,transtype;                                   <<a00.04>>44035000
  byte array message;                                         <<a00.04>>44040000
  <<transtype = 2 => apl-ascii bit pairing codes                        44045000
    transtype = 3 => apl-ascii typewriter pairing codes                 44050000
                                                                        44055000
    length is the length in bytes of array message                      44060000
    message is a byte array containing the message to be translated.    44065000
       this array will be entirely converted.                           44070000
>>                                                            <<a00.04>>44075000
begin                                                         <<a00.04>>44080000
entry apltranslatein;  <<entry point for external to internal><<a00.04>>44085000
equate firstchar = %41,  <<all preceeding chars are the same>><<a00.04>>44090000
       lastchar = %176,                                       <<a00.04>>44095000
       numchars = lastchar-firstchar+1;  <<94 in this instance<<a00.04>>44100000
byte array transarray(firstchar:lastchar);  <<holds trans code<<a00.04>>44105000
byte array bitpairout(0:lastchar-1)=pb:=  <<translation array><<a00.04>>44110000
   %131, %41, " ",%174, " ",%120,%113,                        <<a00.04>>44115000
    %53, %52,%120, %55, ",", %75, ".", "/",                   <<a00.04>>44120000
    "0", "1", "2", "3", "4", "5", "6", "7",                   <<a00.04>>44125000
    "8", "9", %76, %74, %43, %45, %47,%121,                   <<a00.04>>44130000
   %101, "a", "b", "c", "d", "e", "f", "g",                   <<a00.04>>44135000
    "h", "i", "j", "k", "l", "m", "n", "o",                   <<a00.04>>44140000
    "p", "q", "r", "s", "t", "u", "v", "w",                   <<a00.04>>44145000
    "x", "y", "z", %73, %77, %72,%137,%106,                   <<a00.04>>44150000
   %113, "a", "b", "c", "d", "e", "f", "g",                   <<a00.04>>44155000
    "h", "i", "j", "k", "l", "m", "n", "o",                   <<a00.04>>44160000
    "p", "q", "r", "s", "t", "u", "v", "w",                   <<a00.04>>44165000
    "x", "y", "z",%135,%115, "}",%124;                        <<a00.04>>44170000
byte array typewriterout(0:lastchar-1)=pb:=  <<translation array>>      44175000
   %131, %41, " ",%176, " ",%120,%113,                        <<a00.04>>44180000
    %72, %42,%120, %55, ",",%137, ".", "/",                   <<a00.04>>44185000
    "0", "1", "2", "3", "4", "5", "6", "7",                   <<a00.04>>44190000
    "8", "9", %76, %74, %43, %45, %46,%121,                   <<a00.04>>44195000
   %101, "a", "b", "c", "d", "e", "f", "g",                   <<a00.04>>44200000
    "h", "i", "j", "k", "l", "m", "n", "o",                   <<a00.04>>44205000
    "p", "q", "r", "s", "t", "u", "v", "w",                   <<a00.04>>44210000
    "x", "y", "z", %73, %77, %47, %51,%106,                   <<a00.04>>44215000
   %113, "a", "b", "c", "d", "e", "f", "g",                   <<a00.04>>44220000
    "h", "i", "j", "k", "l", "m", "n", "o",                   <<a00.04>>44225000
    "p", "q", "r", "s", "t", "u", "v", "w",                   <<a00.04>>44230000
    "x", "y", "z", "{",%115, "}",%124;                        <<a00.04>>44235000
byte array bitpairin(0:lastchar-1)=pb:=  <<translation array>>          44240000
    %42, %42, "<", %44, "=", %46, ">",                        <<a00.04>>44245000
    %50, %51, ")", "(", ",", "+", ".", "/",                   <<a00.04>>44250000
    "0", "1", "2", "3", "4", "5", "6", "7",                   <<a00.04>>44255000
    "8", "9", "]", "[", ";", "-", ":", "\",                   <<a00.04>>44260000
    "_", "A", "B", "C", "D", "E", "F", "G",                   <<a00.04>>44265000
    "H", "I", "J", "'", "L",%174, "N", "O",                   <<a00.04>>44270000
    "*", "?", "R", "S", %176, "U", "V", "W",                  <<a00.04>>44275000
    "X", "^", "Z",%133,%134,%173,%136,%137,                   <<a00.04>>44280000
   %140, "A", "B", "C", "D", "E", "F", "G",                   <<a00.04>>44285000
    "H", "I", "J", "K", "L", "M", "N", "O",                   <<a00.04>>44290000
    "P", "Q", "R", "S", "T", "U", "V", "W",                   <<a00.04>>44295000
    "X", "Y", "Z",%173, "$",%175,%176;                        <<a00.04>>44300000
byte array typewriterin(0:lastchar-1)=pb:=  <<translation array>>       44305000
    %42, ")", "<", %44, "=", ">", "]",                        <<a00.04>>44310000
    %50, %51, %52, %53, ",", "+", ".", "/",                   <<a00.04>>44315000
    "0", "1", "2", "3", "4", "5", "6", "7",                   <<a00.04>>44320000
    "8", "9", "(", "[", ";", %75, ":", "\",                   <<a00.04>>44325000
   %100, "A", "B", "C", "D", "E", "F", "G",                   <<a00.04>>44330000
    "H", "I", "J", "'", "L",%174, "N", "O",                   <<a00.04>>44335000
    "*", "?", "R", "S", %176, "U", "V", "W",                  <<a00.04>>44340000
    "X", "^", "Z", "_",%134,%135,%136, "-",                   <<a00.04>>44345000
   %140, "A", "B", "C", "D", "E", "F", "G",                   <<a00.04>>44350000
    "H", "I", "J", "K", "L", "M", "N", "O",                   <<a00.04>>44355000
    "P", "Q", "R", "S", "T", "U", "V", "W",                   <<a00.04>>44360000
    "X", "Y", "Z",%173,%174,%175, "$";                        <<a00.04>>44365000
if not(2<=transtype<=3) then return;                          <<a00.04>>44370000
transtype := transtype-2;                                     <<a00.04>>44375000
go to doit;                                                   <<a00.04>>44380000
apltranslatein:                                               <<a00.04>>44385000
  if not(2<=transtype<=3) then return;                        <<a00.04>>44390000
doit:                                                         <<a00.04>>44395000
  case transtype of                                           <<a00.04>>44400000
    begin                                                     <<a00.04>>44405000
    move transarray(firstchar):=bitpairout,(numchars);        <<a00.04>>44410000
    move transarray(firstchar):=typewriterout,(numchars);     <<a00.04>>44415000
    move transarray(firstchar):=bitpairin,(numchars);         <<a00.04>>44420000
    move transarray(firstchar):=typewriterin,(numchars);      <<a00.04>>44425000
    end;                                                      <<a00.04>>44430000
while (length:=length-1) >= 0 do  <<work from end to beginning>>        44435000
   if firstchar<=integer(message(length))<=lastchar then  <<in range>>  44440000
      message(length):=transarray(integer(message(length)));  <<a00.04>>44445000
end;                                                          <<a00.04>>44450000
procedure cxmrje executorhead;                                <<<<mrje>>44455000
   option privileged,uncallable;                              <<<<mrje>>44460000
begin                                                         <<<<mrje>>44465000
byte array sysfilename(0:13);                                  <<03058>>44470000
double parms;  <<dummy for errors found by mycommand>>        <<<<mrje>>44475000
byte pointer bparm = parms;   <<pointer for error>>             <<mrje>>44480000
integer numparms;  <<likewise>>                               <<<<mrje>>44485000
logical pin;  <<pin from create of mrje subsys>>              <<<<mrje>>44490000
move sysfilename:="MRJE.PUB.SYS ";                            <<<<mrje>>44495000
mycommand(parmsp,,1,numparms,parms);  <<check for parms>>     <<<<mrje>>44500000
if numparms > 0 then   <<extraneous parameter>>                 <<mrje>>44505000
   cierr(errnum := -warnxparmsignored, bparm);                 <<04785>>44510000
setjcw(getjcw land %37777);  <<clear jcw abort bits>>          <<02.mm>>44515000
create(sysfilename,,pin,parmnum,1);                           <<<<mrje>>44520000
if carry then   <<create of mrje failed>>                       <<mrje>>44525000
   begin                                                        <<mrje>>44530000
   sysfilename(4) := 0;   <<for error message>>                 <<mrje>>44535000
   if createerror then                                          <<mrje>>44540000
      cierr(errnum := subsyscreateerr,,0,@sysfilename)          <<mrje>>44545000
   else   <<load failed>>                                       <<mrje>>44550000
      cierr(errnum := subsysloaderr,,0,@sysfilename);           <<mrje>>44555000
   end                                                          <<mrje>>44560000
else if < then   <<mrje.pub.sys not found>>                     <<mrje>>44565000
   begin                                                        <<mrje>>44570000
   sysfilename(4) := 0;   <<for error message>>                 <<mrje>>44575000
   cierr(errnum := subsnotfound, , 0,@sysfilename);             <<mrje>>44580000
   end                                                          <<mrje>>44585000
else   <<everything ok, do it>>                                 <<mrje>>44590000
   begin                                                        <<mrje>>44595000
   awake(pin*pcbsize,1,2);   <<fire up subsystem>>              <<mrje>>44600000
   cisubsysfinish(0, errnum, parmnum);                          <<mrje>>44605000
   end;                                                         <<mrje>>44610000
end;   <<cxmrje>>                                               <<mrje>>44615000
                                                               <<06842>>44620000
$page   "               NRJE COMMAND EXECUTOR   "              <<06842>>44625000
comment:                                                       <<06842>>44630000
+----------------------------------------------------+         <<06842>>44635000
|                         |                          |         <<06842>>44640000
|  cxnrje                 |   algorithm              |         <<06842>>44645000
|                         |                          |         <<06842>>44650000
|  parses the parameter   |   1.  break parameter    |         <<06842>>44655000
|  list of the :nrje      |       list into tokens.  |         <<06842>>44660000
|  [<wsid>] command, and  |                          |         <<06842>>44665000
|  creates the nrje       |   2.  check parameter.   |         <<06842>>44670000
|  subsystem process.     |                          |         <<06842>>44675000
|                         |                          |         <<06842>>44680000
|                         |       the  nrje command  |         <<06842>>44685000
|  input                  |       has one optional   |         <<06842>>44690000
|                         |       parameter, q work- |         <<06842>>44695000
|                         |       station identifier.|         <<06842>>44700000
|  parmsp                 |       a workstation id   |         <<06842>>44705000
|   pointer to parameter  |       contains one to    |         <<06842>>44710000
|   list                  |       eight characters,  |         <<06842>>44715000
|                         |       is alphanumberic,  |         <<06842>>44720000
|  output                 |       starts with a let- |         <<06842>>44725000
|                         |       ter, and must be   |         <<06842>>44730000
|  errnum                 |       configured in an   |         <<06842>>44735000
|   number of error en-   |       oracle data com-   |         <<06842>>44740000
|   countered  by cxnrje  |       munications config-|         <<06842>>44745000
|                         |       uration file.      |         <<06842>>44750000
|  parmnum                |                          |         <<06842>>44755000
|   number (position) of  |                          |         <<06842>>44760000
|   parameter which is    |                          |         <<06842>>44765000
|   in error              |                          |         <<06842>>44770000
|                         |                          |         <<06842>>44775000
|                         |   3.  clear jcw abort    |         <<06842>>44780000
|                         |       bit.               |         <<06842>>44785000
|                         |                          |         <<06842>>44790000
|                         |   4.  print <cr> <lf> to |         <<06842>>44795000
|                         |       output device.     |         <<06842>>44800000
|                         |                          |         <<06842>>44805000
|                         |   5.  create nrje subsys-|         <<06842>>44810000
|                         |       tem process.       |         <<06842>>44815000
|                         |                          |         <<06842>>44820000
+----------------------------------------------------+         <<06842>>44825000
end of comment;                                                <<06842>>44830000
                                                               <<06842>>44835000
procedure cxnrje executorhead;                                 <<06842>>44840000
option    privileged, uncallable;                              <<06842>>44845000
begin                                                          <<06842>>44850000
                                                               <<06842>>44855000
<<--------- local variable declarations ------------>>         <<06842>>44860000
                                                               <<06842>>44865000
equate  maxcreateparmcount = 4,                                <<06842>>44870000
        nrjeproglen        = 14;                               <<06842>>44875000
                                                               <<06842>>44880000
equate  maxparms    = 1,                                       <<06842>>44885000
        minparms    = 0,                                       <<06842>>44890000
        maxparmlen  = 8,                                       <<06842>>44895000
        minparmlen  = 1,                                       <<06842>>44900000
        delimcount  = 1;                                       <<06842>>44905000
                                                               <<06842>>44910000
integer array    itemnums(0:maxcreateparmcount);               <<06842>>44915000
byte    array    progname(0:nrjeproglen - 1);                  <<06842>>44920000
logical array    items(0:maxcreateparmcount - 1);              <<06842>>44925000
byte    array    infostring(0:maxparmlen);                     <<06842>>44930000
                                                               <<06842>>44935000
integer array    parms(0:(maxparms-1) * 2);                    <<06842>>44940000
byte    array    delimiters(0:delimcount - 1);                 <<06842>>44945000
integer          numparms;                                     <<06842>>44950000
                                                               <<06842>>44955000
byte    array    getconfprocname(0:14);                        <<06842>>44960000
equate           syslib = 0;                                   <<06842>>44965000
integer          getconfplabel, loadnum;                       <<06842>>44970000
                                                               <<06842>>44975000
                                                               <<06842>>44980000
equate maxconfigfilelen = 35;                                  <<06842>>44985000
byte array configfile(0:maxconfigfilelen - 1);                 <<06842>>44990000
integer status;                                                <<06842>>44995000
                                                               <<06842>>45000000
byte pointer parmptr;                                          <<06842>>45005000
                                                               <<06842>>45010000
integer pin;                                                   <<06842>>45015000
                                                               <<06842>>45020000
integer infolen := 8;                                          <<06842>>45025000
                                                               <<06842>>45030000
define  specialchars = parms(1).(10:1)#,                       <<06842>>45035000
        mycommand'parmptr = parms(0)#,                         <<06842>>45040000
        parmlen      = parms(1).(0:8)#;                        <<06842>>45045000
                                                               <<06842>>45050000
equate  cierrendofstring   = 0,                                <<06842>>45055000
        clearabortbitsmask = %37777,                           <<06842>>45060000
        createprocnoerrs   = 0,                                <<06842>>45065000
        createprocnoprog   = 6,                                <<06842>>45070000
        getconfignoerrs    = 0,                                <<06842>>45075000
        getconfignowsid    = 1010,                             <<06842>>45080000
        subsysendmsg       = 3,                                <<06842>>45085000
        endofparms         = 0;                                <<06842>>45090000
                                                               <<06842>>45095000
 equate carriagereturn     = %15,                              <<06842>>45100000
        flagcode           = 3,                                <<06842>>45105000
        activatecode       = 10,                               <<06842>>45110000
        infoptrcode        = 11,                               <<06842>>45115000
        infocountcode      = 12,                               <<06842>>45120000
        loaderflags        = %131001,<<stackdump unc>>         <<06842>>45125000
                                     <<dl to qi bit >>         <<06842>>45130000
                                     <<qi to s  bit >>         <<06842>>45135000
                                     <<ascii dump   >>         <<06842>>45140000
        sonwait            = 2;                                <<06842>>45145000
                                                               <<06842>>45150000
                                                               <<06842>>45155000
intrinsic loadproc, unloadproc;                                <<06842>>45160000
                                                               <<06842>>45165000
<<-------------------- cxnrje ------------------->>            <<06842>>45170000
                                                               <<06842>>45175000
                                                               <<06842>>45180000
errnum := 0; parmnum := 0;                                     <<06842>>45185000
                                                               <<06842>>45190000
<< 1. >>                                                       <<06842>>45195000
delimiters := carriagereturn;                                  <<06842>>45200000
mycommand( parmsp, delimiters, maxparms,                       <<06842>>45205000
           numparms, parms               );                    <<06842>>45210000
@parmptr := mycommand'parmptr;                                 <<06842>>45215000
                                                               <<06842>>45220000
<< 2. >>                                                       <<06842>>45225000
if numparms = maxparms then                                    <<06842>>45230000
begin                                                          <<06842>>45235000
                                                               <<06842>>45240000
  if ( parmlen > maxparmlen ) then                             <<06842>>45245000
  begin                                                        <<06842>>45250000
    parmnum := 1;                                              <<06842>>45255000
    cierr( errnum := wsidtoolong, parmptr );                   <<06842>>45260000
    return;                                                    <<06842>>45265000
  end;                                                         <<06842>>45270000
                                                               <<06842>>45275000
  if logical(specialchars) or                                  <<06842>>45280000
     ( parmptr <> alpha  ) then                                <<06842>>45285000
  begin                                                        <<06842>>45290000
    parmnum := 1;                                              <<06842>>45295000
    cierr( errnum := badwsid, parmptr );                       <<06842>>45300000
    return;                                                    <<06842>>45305000
  end;                                                         <<06842>>45310000
                                                               <<06842>>45315000
  move infostring := parmptr, (parmlen);                       <<06842>>45320000
                                                               <<06842>>45325000
  if parmlen < maxparmlen then                                 <<06842>>45330000
  begin                                                        <<06842>>45335000
    infostring(parmlen) := " ";                                <<06842>>45340000
    move infostring( parmlen + 1 ) :=                          <<06842>>45345000
      infostring(parmlen),                                     <<06842>>45350000
      ( maxparmlen - ( parmlen + 1 ) );                        <<06842>>45355000
  end;                                                         <<06842>>45360000
  infostring(maxparmlen) := cierrendofstring;                  <<06842>>45365000
                                                               <<06842>>45370000
  move getconfprocname := "NCONGET'CONFIG ";                   <<06842>>45375000
  loadnum := loadproc( getconfprocname,                        <<06842>>45380000
                       syslib,                                 <<06842>>45385000
                       getconfplabel    );                     <<06842>>45390000
  if <> then                                                   <<06842>>45395000
  begin                                                        <<06842>>45400000
    cierr( errnum := badconfaccess );                          <<06842>>45405000
    return;                                                    <<06842>>45410000
  end;                                                         <<06842>>45415000
                                                               <<06842>>45420000
  tos := @infostring;                                          <<06842>>45425000
  tos := @configfile;                                          <<06842>>45430000
  tos := @status;                                              <<06842>>45435000
  tos := getconfplabel;                                        <<06842>>45440000
  assemble( pcal 0 );                                          <<06842>>45445000
                                                               <<06842>>45450000
  if status = getconfignowsid then                             <<06842>>45455000
  begin                                                        <<06842>>45460000
    parmnum := 1;                                              <<06842>>45465000
    cierr( errnum := wsidnotconf,                              <<06842>>45470000
           parmptr,                                            <<06842>>45475000
           0,                                                  <<06842>>45480000
           @infostring             );                          <<06842>>45485000
    return;                                                    <<06842>>45490000
  end                                                          <<06842>>45495000
  else if status <> getconfignoerrs then                       <<06842>>45500000
  begin                                                        <<06842>>45505000
    cierr( errnum := badconfaccess );                          <<06842>>45510000
    return;                                                    <<06842>>45515000
  end;                                                         <<06842>>45520000
                                                               <<06842>>45525000
  unloadproc( loadnum );                                       <<06842>>45530000
  if <> then                                                   <<06842>>45535000
  begin                                                        <<06842>>45540000
    cierr( errnum := badconfaccess );                          <<06842>>45545000
    return;                                                    <<06842>>45550000
  end;                                                         <<06842>>45555000
end;                                                           <<06842>>45560000
                                                               <<06842>>45565000
                                                               <<06842>>45570000
<< 3. >>                                                       <<06842>>45575000
setjcw( getjcw land clearabortbitsmask );                      <<06842>>45580000
                                                               <<06842>>45585000
                                                               <<06842>>45590000
<< 4. >>                                                       <<06842>>45595000
nextline;                                                      <<06842>>45600000
                                                               <<06842>>45605000
<< 5. >>                                                       <<06842>>45610000
itemnums := flagcode;         itemnums(1) := activatecode;     <<06842>>45615000
                                                               <<06842>>45620000
items := loaderflags;   items(1) := sonwait;                   <<06842>>45625000
                                                               <<06842>>45630000
if numparms = maxparms then                                    <<06842>>45635000
begin                                                          <<06842>>45640000
  itemnums(2) := infocountcode;                                <<06842>>45645000
  itemnums(3) := infoptrcode;                                  <<06842>>45650000
  itemnums(4) := endofparms;                                   <<06842>>45655000
  items(2) := infolen;                                         <<06842>>45660000
  items(3) := @infostring;                                     <<06842>>45665000
end                                                            <<06842>>45670000
else itemnums(2) := endofparms;                                <<06842>>45675000
                                                               <<06842>>45680000
move progname := "NRJE.NRJE.SYS ";                             <<06842>>45685000
                                                               <<06842>>45690000
                                                               <<06842>>45695000
createprocess( errnum, pin , progname, itemnums, items );      <<06842>>45700000
if errnum = createprocnoerrs then                              <<06842>>45705000
  cisubsysfinish( subsysendmsg, errnum, parmnum )              <<06842>>45710000
else if errnum = createprocnoprog then                         <<06842>>45715000
  cierr( errnum := nrjenotfound )                              <<06842>>45720000
else createproc'err( errnum, errnum );                         <<06842>>45725000
                                                               <<06842>>45730000
end;  << procedure cxnrje >>                                   <<06842>>45735000
procedure cx3270 executorhead;                                          45740000
   option privileged,uncallable;                               <<00184>>45745000
begin                                                          <<00184>>45750000
<< fire up the iml/3000 subsystem (also known in   >>          <<01165>>45755000
<< some circles as the ibm 3270).                  >>          <<01165>>45760000
<<                                                 >>          <<01165>>45765000
<< the iml subsystem can now be invoked via four  >>           <<02845>>45770000
<< commands, iml and imf for regular use, and     >>           <<02845>>45775000
<< imlmgr or imfmgr for manager. the syntax was   >>           <<02845>>45780000
<< changed to include the format and priority key->>           <<02845>>45785000
<< words. the complete syntax is as follows:      >>           <<02845>>45790000
<<                                                >>           <<02845>>45795000
<< imf [;][e[nhance] = 0|1|2|3] [;][b[lanks]]     >>           <<02845>>45800000
<<     [;][f[ormat] = 1|2|3|4]                    >>           <<02845>>45805000
<<     [;][p[riority] =1|2|3|4|5|6|7|8|9|11|12|13]>>           <<02845>>45810000
<<                                                >>           <<02845>>45815000
<<                                                >>           <<02845>>45820000
<<  the parameters may be in either sequence or    >>          <<01165>>45825000
<<  may be omitted entirely.                       >>          <<01165>>45830000
                                                               <<01165>>45835000
logical manager;                                               <<00184>>45840000
byte array sysfilename(0:17),entryname(0:9);                   <<00184>>45845000
logical flag := 0,prog'parm := [4/0,3/2,1/0,4/8,4/0];          <<02845>>45850000
equate                                                         <<02845>>45855000
   pkeylistl = 56,                                             <<02845>>45860000
   maxparms = 7,                                               <<02845>>45865000
   equals = 1,                                                 <<02845>>45870000
   semicolon = 0,                                              <<02845>>45875000
   cr = 2;                                                     <<02845>>45880000
byte array pkeylist(0:pkeylistl - 1) = pb :=                   <<02845>>45885000
   10,7,"ENHANCE",0,                                           <<02845>>45890000
   9,6,"FORMAT",1,                                             <<02845>>45895000
   11,8,"PRIORITY",2,                                          <<02845>>45900000
   9,6,"BLANKS",3,                                             <<02845>>45905000
   4,1,"E",0,                                                  <<02845>>45910000
   4,1,"F",1,                                                  <<02845>>45915000
   4,1,"P",2,                                                  <<02845>>45920000
   4,1,"B",3,                                                  <<02845>>45925000
   0;                                                          <<02845>>45930000
byte array keylist(0:pkeylistl - 1);                           <<02845>>45935000
double delim := [8/";",8/"=",8/%15,8/0]d;                      <<02845>>45940000
byte array delims(*) = delim;                                  <<02845>>45945000
integer parmlen,nextdelim,numparms,result;                     <<02845>>45950000
double array parms(0:maxparms - 1);                            <<02845>>45955000
byte pointer parmptr,dictptr;                                  <<02845>>45960000
define                                                         <<02845>>45965000
   enhance = (12:4)#,                                          <<02845>>45970000
   format = (4:3)#,                                            <<02845>>45975000
   priority = (8:4)#,                                          <<02845>>45980000
   blanks = (7:1)#,                                            <<02845>>45985000
   enh = (0:1)#,                                               <<02845>>45990000
   fmt = (1:1)#,                                               <<02845>>45995000
   pri = (2:1)#,                                               <<02845>>46000000
   delimtype = (13:3)#;                                        <<02845>>46005000
                                                               <<01165>>46010000
logical pin;  <<pin from create of 3270 subsys>>               <<00184>>46015000
entry cx3270mgr;                                               <<01165>>46020000
                                                               <<00184>>46025000
                                                               <<01165>>46030000
subroutine getnext;                                            <<02845>>46035000
<< sets parmptr to appropriate parameter, gets parameter >>    <<02845>>46040000
<< length and delimiter type. called upon advancing to   >>    <<02845>>46045000
<< next parameter.                                       >>    <<02845>>46050000
begin                                                          <<02845>>46055000
   tos := parms(parmnum);                                      <<02845>>46060000
   nextdelim := s0.delimtype;                                  <<02845>>46065000
   parmlen := tos&lsr(8);                                      <<02845>>46070000
   @parmptr := tos;                                            <<02845>>46075000
   parmnum := parmnum + 1;                                     <<02845>>46080000
end; << subroutine getnext >>                                  <<02845>>46085000
                                                               <<02845>>46090000
                                                               <<02845>>46095000
logical subroutine procenhance;                                <<02845>>46100000
begin                                                          <<02845>>46105000
   procenhance := false;                                       <<02845>>46110000
   if flag.enh then                                            <<02845>>46115000
      cierr(errnum := -redndenh,parmptr);                      <<02845>>46120000
   flag.enh := true;                                           <<02845>>46125000
   if nextdelim <> equals then                                 <<02845>>46130000
      begin                                                    <<02845>>46135000
         cierr(errnum := expctequal,parmptr(parmlen));         <<02845>>46140000
         return;                                               <<02845>>46145000
      end;                                                     <<02845>>46150000
   getnext;                                                    <<02845>>46155000
   result := binary(parmptr,parmlen);                          <<02845>>46160000
   if <> or not (0 <= result <= 3) then                        <<02845>>46165000
      cierr(errnum := illvalenh,parmptr)                       <<02845>>46170000
   else                                                        <<02845>>46175000
      begin                                                    <<02845>>46180000
         prog'parm.enhance := result;                          <<02845>>46185000
         procenhance := true;                                  <<02845>>46190000
      end;                                                     <<02845>>46195000
end; << subroutine procenhance >>                              <<02845>>46200000
                                                               <<02845>>46205000
                                                               <<02845>>46210000
logical subroutine procformat;                                 <<02845>>46215000
begin                                                          <<02845>>46220000
   procformat := false;                                        <<02845>>46225000
   if flag.fmt then                                            <<02845>>46230000
      cierr(errnum := -redndfmt,parmptr);                      <<02845>>46235000
   flag.fmt := true;                                           <<02845>>46240000
   if nextdelim <> equals then                                 <<02845>>46245000
      begin                                                    <<02845>>46250000
         cierr(errnum := expctequal,parmptr(parmlen));         <<02845>>46255000
         return;                                               <<02845>>46260000
      end;                                                     <<02845>>46265000
   getnext;                                                    <<02845>>46270000
   result := binary(parmptr,parmlen);                          <<02845>>46275000
   if <> or not (1 <= result <= 4) then                        <<02845>>46280000
      cierr(errnum := illvalfmt,parmptr)                       <<02845>>46285000
   else                                                        <<02845>>46290000
      begin                                                    <<02845>>46295000
         prog'parm.format := result;                           <<02845>>46300000
         procformat := true;                                   <<02845>>46305000
      end;                                                     <<02845>>46310000
end; << subroutine procformat >>                               <<02845>>46315000
                                                               <<02845>>46320000
                                                               <<02845>>46325000
logical subroutine procpriority;                               <<02845>>46330000
begin                                                          <<02845>>46335000
   procpriority := false;                                      <<02845>>46340000
   if flag.pri then                                            <<02845>>46345000
      cierr(errnum := -redndpri,parmptr);                      <<02845>>46350000
   flag.pri := true;                                           <<02845>>46355000
   if nextdelim <> equals then                                 <<02845>>46360000
      begin                                                    <<02845>>46365000
         cierr(errnum := expctequal,parmptr(parmlen));         <<02845>>46370000
         return;                                               <<02845>>46375000
      end;                                                     <<02845>>46380000
   getnext;                                                    <<02845>>46385000
   result := binary(parmptr,parmlen);                          <<02845>>46390000
   if <> or not (1 <= result <= 13) then                       <<02845>>46395000
      cierr(errnum := illvalpri,parmptr)                       <<02845>>46400000
   else                                                        <<02845>>46405000
      begin                                                    <<02845>>46410000
         prog'parm.priority := result;                         <<02845>>46415000
         procpriority := true;                                 <<02845>>46420000
      end;                                                     <<02845>>46425000
end; << subroutine procpriority >>                             <<02845>>46430000
                                                               <<02845>>46435000
                                                               <<02845>>46440000
if (manager := false) then                                     <<02845>>46445000
cx3270mgr: manager := true;                                    <<02845>>46450000
mycommand(parmsp,delims,maxparms,numparms,parms);              <<02845>>46455000
if <> then                                                     <<02845>>46460000
   begin                                                       <<02845>>46465000
      cierr(errnum := toomanyparms);                           <<02845>>46470000
      return;                                                  <<02845>>46475000
   end;                                                        <<02845>>46480000
if numparms <> 0 then << evidently found some >>               <<02845>>46485000
   begin                                                       <<02845>>46490000
      move keylist := pkeylist,(pkeylistl);                    <<02845>>46495000
      do                                                       <<02845>>46500000
         begin                                                 <<02845>>46505000
            getnext;                                           <<02845>>46510000
            if parmlen = 0 then << empty parameter >>          <<02845>>46515000
               cierr(errnum := -fileextrandelim,parmptr)       <<02845>>46520000
            else                                               <<02845>>46525000
               begin << look for a keyword >>                  <<02845>>46530000
                  tos := search(parmptr,parmlen,keylist        <<02845>>46535000
                                ,dictptr);                     <<02845>>46540000
                  if tos <> 0 then                             <<02845>>46545000
                     case integer(dictptr) of                  <<02845>>46550000
                        begin                                  <<02845>>46555000
                           << 0 >>                             <<02845>>46560000
                           if not procenhance then             <<02845>>46565000
                              return;                          <<02845>>46570000
                           << 1 >>                             <<02845>>46575000
                           if not procformat then              <<02845>>46580000
                              return;                          <<02845>>46585000
                           << 2 >>                             <<02845>>46590000
                           if not procpriority then            <<02845>>46595000
                              return;                          <<02845>>46600000
                           << 3 >>                             <<02845>>46605000
                           prog'parm.blanks := 1;              <<02845>>46610000
                        end                                    <<02845>>46615000
                  else << unknown keyword >>                   <<02845>>46620000
                     begin                                     <<02845>>46625000
                        cierr(errnum := unknownkey,parmptr);   <<02845>>46630000
                        return;                                <<02845>>46635000
                     end;                                      <<02845>>46640000
               end;                                            <<02845>>46645000
         end << keyword loop >>                                <<02845>>46650000
      until nextdelim <> semicolon;                            <<02845>>46655000
      if nextdelim <> cr then                                  <<02845>>46660000
         begin                                                 <<02845>>46665000
            cierr(errnum := expectsemic,parmptr(parmlen));     <<02845>>46670000
            return;                                            <<02845>>46675000
         end;                                                  <<02845>>46680000
   end; << parameters exist >>                                 <<02845>>46685000
setjcw(getjcw land %37777);  <<clear jcw abort bits>>          <<02.mm>>46690000
                                                               <<00184>>46695000
if manager                                                     <<00184>>46700000
  then move entryname := "TTSMGR "                             <<00184>>46705000
  else move entryname := "  ";                                 <<00184>>46710000
                                                               <<00184>>46715000
move sysfilename := "TTSUSER.PUB.SYS ";                        <<01165>>46720000
create(sysfilename,entryname,pin,prog'parm,1);                 <<02845>>46725000
if carry then   <<create of iml subsystem failed>>             <<01424>>46730000
   begin                                                       <<00184>>46735000
   scan sysfilename until "..",1;                              <<00184>>46740000
   bps0 := 0;       << delimit string >>                       <<00184>>46745000
   del;                                                        <<00184>>46750000
   if createerror then                                         <<00184>>46755000
      cierr(errnum := subsyscreateerr,,0,@sysfilename)         <<00184>>46760000
   else   <<load failed>>                                      <<00184>>46765000
      cierr(errnum := subsysloaderr,,0,@sysfilename);          <<00184>>46770000
   end                                                         <<00184>>46775000
else if < then   <<ttsuser.pub.sys not found>>                 <<00184>>46780000
   begin                                                       <<00184>>46785000
   scan sysfilename until "..",1;                              <<00184>>46790000
   bps0 := 0;       << delimit string >>                       <<00184>>46795000
   del;                                                        <<00184>>46800000
   cierr(errnum := subsnotfound, , 0,@sysfilename);            <<00184>>46805000
   end                                                         <<00184>>46810000
else   <<everything ok, do it>>                                <<00184>>46815000
   begin                                                       <<00184>>46820000
   awake(pin*pcbsize,1,2);   <<fire up subsystem>>             <<00184>>46825000
   cisubsysfinish(0, errnum, parmnum);                         <<00184>>46830000
   end;                                                        <<00184>>46835000
end;   <<cx3270, cx3270mgr>>                                   <<00184>>46840000
procedure cx3270control executorhead;                          <<01165>>46845000
  option privileged,uncallable;                                <<01165>>46850000
begin                                                          <<01165>>46855000
  byte array proc'name(0:17);                                  <<01424>>46860000
  byte array errmsg(0:4);                                      <<01538>>46865000
  integer msg'len;                                             <<01538>>46870000
  integer proc'id, plabel, x=x;                                <<01424>>46875000
  define asmb = assemble#;                                     <<01424>>46880000
  intrinsic loadproc,unloadproc;                               <<01424>>46885000
                                                               <<01424>>46890000
  subroutine cximlcontrol executorhead;                        <<01424>>46895000
    begin                                                      <<01424>>46900000
    x := tos;  << save return address >>                       <<01424>>46905000
    tos := plabel;                                             <<01424>>46910000
    asmb( pcal 0 );                                            <<01424>>46915000
    tos := x;                                                  <<01424>>46920000
    return 0;  << procedure deleted parms >>                   <<01424>>46925000
    end;                                                       <<01424>>46930000
                                                               <<01424>>46935000
  move proc'name := "CXIMLCONTROL ";                           <<01424>>46940000
  proc'id := loadproc(proc'name,0,plabel);                     <<01424>>46945000
  if <> then                                                   <<01424>>46950000
    begin                                                      <<01424>>46955000
    move errmsg := "IML",2;                                    <<01538>>46960000
    msg'len :=tos - @errmsg;                                   <<01538>>46965000
    errmsg(msg'len) := 0;                                      <<01538>>46970000
    cierr(errnum := subsnotfound,,0,@errmsg);                  <<01538>>46975000
    return;                                                    <<01424>>46980000
    end;                                                       <<01424>>46985000
                                                               <<01424>>46990000
  cximlcontrol(parmsp,errnum,parmnum);                         <<01424>>46995000
                                                               <<01424>>47000000
  unloadproc(proc'id);                                         <<01424>>47005000
                                                               <<01424>>47010000
end;  <<cx3270control>>                                        <<01424>>47015000
$control segment = cisubs                                      <<u.rao>>47020000
      procedure cxrje executorhead;                                     47025000
      option privileged,uncallable;                                     47030000
      begin                                                             47035000
      byte array progfile(0:11);                                        47040000
      byte array buildname(0:7);                                        47045000
      integer numparms,pcnt:=-1;                                        47050000
      double array parms(0:4);                                 <<u.rao>>47055000
      lbparmdecs;                                                       47060000
      logical comcr:=%26015,t:=1,parm:=0,pin;                           47065000
      byte pointer fname;                                               47070000
      subroutine cleanup;                                               47075000
         begin                                                          47080000
         delimpfile(parm,buildname);                                    47085000
         end;<<clean up>>                                               47090000
      move progfile:="RJE.PUB.SYS ";                                    47095000
      move buildname:="RJE";                                            47100000
      mycommand(parmsp,comcr,5,numparms,parms);                <<u.rao>>47105000
      if numparms>4 then  <<too many parameters for rje>>      <<u.rao>>47110000
         begin                                                 <<u.rao>>47115000
         parmnum := 5;                                         <<u.rao>>47120000
         tos := errnum := subs2mp;                             <<u.rao>>47125000
         tos := lparm(8);                                      <<u.rao>>47130000
         cierr(*,*,%10000,4);                                  <<u.rao>>47135000
         return                                                <<u.rao>>47140000
         end;                                                  <<u.rao>>47145000
      while(pcnt:=pcnt+1)<numparms do                                   47150000
      if (t:=bparm(2+pcnt&asl(2)))<>0 then                              47155000
         begin                                                          47160000
         @fname:=lparm(pcnt&asl(1));                                    47165000
         case pcnt of                                                   47170000
            begin                                                       47175000
               begin<<command>>                                         47180000
               move buildname(3):="COM ";                               47185000
               parm.(15:1):=1;                                          47190000
               end;                                                     47195000
               begin<<input>>                                           47200000
               move buildname(3):="IN ";                                47205000
               parm.(13:1):=1;                                          47210000
               end;                                                     47215000
               begin<<list>>                                            47220000
               move buildname(3):="LIST ";                              47225000
               parm.(14:1):=1;                                          47230000
               end;                                                     47235000
               begin<<punch>>                                           47240000
               move buildname(3):="PUNCH ";                             47245000
               parm.(12:1):=1;                                          47250000
               end;                                                     47255000
           end;                                                         47260000
           errnum := cyimplctfile'(buildname,fname,t);         <<u.rao>>47265000
           if <> then   <<error in name>>                      <<u.rao>>47270000
              begin                                            <<u.rao>>47275000
              cleanup;                                         <<u.rao>>47280000
              parmnum :=2;                                     <<u.rao>>47285000
              return                                           <<u.rao>>47290000
              end;                                             <<u.rao>>47295000
         end;                                                  <<u.rao>>47300000
      setjcw(getjcw land %37777);  <<clear jcw abort bits>>    <<02.mm>>47305000
      tos := tos+0;  <<clear carry before create>>             <<u.rao>>47310000
      create(progfile,,pin,parm,1);                                     47315000
      if carry then                                                     47320000
         begin                                                          47325000
         cleanup;                                                       47330000
         progfile(3) := 0;  <<set up rje as parm to genmsg>>   <<u.rao>>47335000
         if createerror then                                   <<u.rao>>47340000
            cierr(errnum := subsyscreateerr,,0,@progfile)      <<u.rao>>47345000
         else                                                  <<u.rao>>47350000
            cierr(errnum := subsysloaderr,,0,@progfile);       <<u.rao>>47355000
         return;                                               <<u.rao>>47360000
         end;                                                           47365000
      if< then                                                          47370000
         begin                                                          47375000
         cleanup;                                                       47380000
         progfile(3) := 0;                                     <<u.rao>>47385000
         cierr(errnum := subsnotfound,,0,@progfile);           <<04785>>47390000
         return;                                               <<u.rao>>47395000
         end;                                                           47400000
      nextline;                                                         47405000
      awake(pin*pcbsize,1,2);                                           47410000
      cleanup;                                                          47415000
      cisubsysfinish(3, errnum, parmnum);                      <<u.rao>>47420000
end;   <<cxrje>>                                               <<u.rao>>47425000
   integer procedure cyimplctfile'(lhs,rhs,lenr);              <<u.rao>>47430000
   value lenr;                                                 <<u.rao>>47435000
   integer lenr;                                               <<u.rao>>47440000
   byte array lhs, rhs;                                        <<u.rao>>47445000
   option privileged, uncallable;                              <<u.rao>>47450000
                                                               <<u.rao>>47455000
begin                                                          <<u.rao>>47460000
<< this procedure does implicit file equates for >>            <<u.rao>>47465000
<< the subsystem commands.  for example, it does >>            <<u.rao>>47470000
<< an equate spltext = <user supplied file name> >>            <<u.rao>>47475000
<< for the spl compiler, if required.  file      >>            <<u.rao>>47480000
<< equates should only be done if the user       >>            <<u.rao>>47485000
<< explicitly provided a file name.  the usual   >>            <<u.rao>>47490000
<< communication path to the compilers is through>>            <<u.rao>>47495000
<< the parm parameter in the create intrinsic.   >>            <<u.rao>>47500000
<< see the individual subsystem for specifics.   >>            <<u.rao>>47505000
<< incidentally, the reader should note that     >>            <<u.rao>>47510000
<< this routine is responsible for parsing the   >>            <<u.rao>>47515000
<< user supplied file name and for reporting     >>            <<u.rao>>47520000
<< errors related to the procedure's inability   >>            <<u.rao>>47525000
<< to add the equate to the jdt.  a companion    >>            <<u.rao>>47530000
<< procedure, delimpfile, deletes the file equate>>            <<u.rao>>47535000
<< on termination of the compiler.               >>            <<u.rao>>47540000
                                                               <<u.rao>>47545000
integer resultspace=cyimplctfile';                             <<u.rao>>47550000
byte blank := " ";                                             <<u.rao>>47555000
      logical array fentry(0:31);                              <<u.rao>>47560000
byte array bfentry(*) = fentry;                                <<u.rao>>47565000
byte pointer bgptr := @blank,                                  <<u.rao>>47570000
             baptr := @blank,                                  <<u.rao>>47575000
             berrptr;                                          <<u.rao>>47580000
logical gptr = bgptr,                                          <<u.rao>>47585000
        aptr = baptr,                                          <<u.rao>>47590000
        errptr = berrptr;                                      <<u.rao>>47595000
logical sysflag := false;                                      <<u.rao>>47600000
integer                                                        <<04980>>47605000
   dispos'indx,                                                <<04980>>47610000
   foption'indx,                                               <<04980>>47615000
   fillerlen,                                                  <<04980>>47620000
   fentrylen;       << length of feq work entry from the >>    <<04980>>47625000
                    << PMASK WORD TO/INCLUDING "LENGTH   >>    <<04980>>47630000
                    << FORMS=" WORD                      >>    <<04980>>47635000
equate                                                         <<04980>>47640000
   filler     = 0,                                             <<04980>>47645000
   jdtworklen = 15; << work length-len of actual name >>       <<06566>>47650000
                                                               <<u.rao>>47655000
cc := cce;                                                     <<u.rao>>47660000
<<first task is to check validity of file name>>               <<u.rao>>47665000
tos := 0;                                                      <<u.rao>>47670000
tos := @rhs;                                                   <<u.rao>>47675000
tos := lenr;                                                   <<u.rao>>47680000
tos := checkfilename'(*,gptr,aptr,errptr);                     <<u.rao>>47685000
if < then  <<error in parsing name>>                           <<u.rao>>47690000
   begin                                                       <<u.rao>>47695000
   cyimplctfile' := s0;                                        <<u.rao>>47700000
   cc := ccg;                                                  <<u.rao>>47705000
   cierr(*,berrptr);                                           <<u.rao>>47710000
   return                                                      <<u.rao>>47715000
   end                                                         <<u.rao>>47720000
else if > then                                                 <<u.rao>>47725000
   if s0=0 then  <<back referenced file name>>                 <<u.rao>>47730000
      begin                                                    <<u.rao>>47735000
      del;                                                     <<u.rao>>47740000
      fentry := 1;  <<name present bit in pmask>>              <<u.rao>>47745000
      fentry(1) := %1000;  <<set pointer bit>>                 <<u.rao>>47750000
      fentry(2) := (lenr-1)&lsl(8);  <<name length>>           <<u.rao>>47755000
      move bfentry(6) := rhs(1),(lenr-1);                      <<u.rao>>47760000
      tos := xaddjtentry(lhs,blank,blank,-3,(14+lenr&lsr(1)),  <<u.rao>>47765000
                 fentry,rhs(1),bgptr,baptr);                   <<u.rao>>47770000
      case tos of                                              <<u.rao>>47775000
         begin                                                 <<u.rao>>47780000
         ;  <<ok return>>                                      <<u.rao>>47785000
         begin                                                 <<u.rao>>47790000
            cc := ccl;                                         <<u.rao>>47795000
            cierr(resultspace := feqtabfull);                  <<u.rao>>47800000
         end;                                                  <<u.rao>>47805000
         ;  <<duplicate name - can't happen>>                  <<u.rao>>47810000
         begin   <<actual designator not found>>               <<u.rao>>47815000
            cc := ccl;                                         <<u.rao>>47820000
            qualifyfilename(rhs(1),bfentry);                   <<u.rao>>47825000
            cierr(resultspace := filebrefmisades,,0,@bfentry); <<u.rao>>47830000
         end;                                                  <<u.rao>>47835000
         begin  <<too many back references to this adesignator><<u.rao>>47840000
            cc := ccl;                                         <<u.rao>>47845000
            qualifyfilename(rhs(1),bfentry);                   <<u.rao>>47850000
            cierr(resultspace := toomanyfeqbref,,0,@bfentry);  <<u.rao>>47855000
         end;                                                  <<u.rao>>47860000
         begin  << circular file equation >>                   <<00834>>47865000
            cc := ccl;                                         <<00834>>47870000
            cierr(resultspace := circularfeq);                 <<00834>>47875000
         end;                                                  <<00834>>47880000
         end;  <<of case>>                                     <<u.rao>>47885000
      end                                                      <<u.rao>>47890000
   else                                                        <<u.rao>>47895000
      begin  <<system defined file>>                           <<u.rao>>47900000
      sysflag := true;                                         <<u.rao>>47905000
      fentry := %20;  <<default designator bit>>               <<u.rao>>47910000
      fentry(1) := 0;  <<pmask word 2>>                        <<u.rao>>47915000
      fentry(2) := 0;  <<name length>>                         <<u.rao>>47920000
      fentry(3) := tos&lsl(3);  <<foptions word>>              <<u.rao>>47925000
      fentry(4) := filler; << aoptions word >>                 <<04980>>47930000
      move fentry(5) := fentry(4),(9);     << zero out ent.>>  <<04980>>47935000
      tos := addjtentry(lhs,blank,blank,-3,14,fentry);         <<04980>>47940000
      if tos <> 0 then   <<error return from directory>>       <<u.rao>>47945000
         begin                                                 <<u.rao>>47950000
         cc := ccl;                                            <<u.rao>>47955000
         cierr(resultspace := feqtabfull);                     <<u.rao>>47960000
         end;                                                  <<u.rao>>47965000
      end                                                      <<u.rao>>47970000
else   <<regular file name>>                                   <<u.rao>>47975000
<<********************************************************>>   <<04980>>47980000
<< regular file name;  need to add the file equation to   >>   <<04980>>47985000
<< the jdt in the jfeq table.  when adding a file equation>>   <<04980>>47990000
<< a full file equation must be added, meaning the        >>   <<04980>>47995000
<< foption, aoption, # buffers, dispostion, etc fields    >>   <<04980>>48000000
<< be included as part of the file equation entry whether >>   <<04980>>48005000
<< they are used or not.  because this part of the pro-   >>   <<04980>>48010000
<< cedure does not need the information from the foption  >>   <<04980>>48015000
<< word to the end of the entry those words have been     >>   <<04980>>48020000
<< zeroed out, with the exception of the disposition word >>   <<04980>>48025000
<< which has a one in it to indicate a save disposition.  >>   <<04980>>48030000
<<********************************************************>>   <<04980>>48035000
   begin                                                       <<u.rao>>48040000
   foption'indx := ((lenr+1)&lsr(1)) + 3;    <<index from >>   <<04980>>48045000
                                          <<start of   >>      <<04980>>48050000
                                          <<work area  >>      <<04980>>48055000
   dispos'indx := ((lenr+1)&lsr(1)) + 5;                       <<04980>>48060000
   fentrylen := ((lenr+1)&lsr(1)) + jdtworklen;                <<04980>>48065000
   fentry := 1;  <<name present>>                              <<u.rao>>48070000
   fentry(1) := 0;                                             <<u.rao>>48075000
   fentry(2) := lenr&lsl(8); <<name length in upper byte>>     <<u.rao>>48080000
   move bfentry(6) := rhs,(lenr);                              <<u.rao>>48085000
   fillerlen := fentrylen - foption'indx;                      <<04980>>48090000
   fentry(foption'indx) := filler;                             <<04980>>48095000
   move fentry(foption'indx + 1) :=                            <<04980>>48100000
        fentry(foption'indx),(fillerlen - 1);                  <<04980>>48105000
   fentry(dispos'indx) := 1; << put as save disposition>>      <<04980>>48110000
   tos := addjtentry(lhs,blank,blank,-3,fentrylen,fentry);     <<04980>>48115000
<< file equation has been added to jdt at this point >>        <<04980>>48120000
   if tos <> 0 then   <<error return from directory>>          <<u.rao>>48125000
      begin                                                    <<u.rao>>48130000
      cc := ccl;                                               <<u.rao>>48135000
      cierr(resultspace := feqtabfull);                        <<u.rao>>48140000
      end;                                                     <<u.rao>>48145000
   end;                                                        <<u.rao>>48150000
end;                                                           <<u.rao>>48155000
procedure delimpfile(parm,fname);                                       48160000
                                                                        48165000
<< ======================================================== >> <<06130>>48170000
<<                  procedure delimplfile                   >> <<06130>>48175000
<<                                                          >> <<06130>>48180000
<<     this procedure deletes the implicit file equations   >> <<06130>>48185000
<<     made by various compilers and the segmenter.  it     >> <<06130>>48190000
<<     knows which equations are there by the bits set in   >> <<06130>>48195000
<<     the input parm word.                                 >> <<06130>>48200000
<<                                                          >> <<06130>>48205000
<<      ** input **                                         >> <<06130>>48210000
<<            parm  --  the logical word which describes    >> <<06130>>48215000
<<                      which equates have been made as     >> <<06130>>48220000
<<                      follows:                            >> <<06130>>48225000
<<                         bit            file equate       >> <<06130>>48230000
<<                          15            xxxxtext          >> <<06130>>48235000
<<                          14            xxxxlist          >> <<06130>>48240000
<<                          13            xxxxusl           >> <<06130>>48245000
<<                          12            xxxxmast          >> <<06130>>48250000
<<                          11            xxxxnew           >> <<06130>>48255000
<<                          10            xxxxwksp          >> <<06130>>48260000
<<                                                          >> <<06130>>48265000
<<      ** output **                                        >> <<06130>>48270000
<<                                                          >> <<06130>>48275000
<<            none                                          >> <<06130>>48280000
                                                               <<06130>>48285000
   value parm;                                                          48290000
   logical parm;                                                        48295000
   byte array fname;                                                    48300000
   option privileged, uncallable;                                       48305000
begin logical blank := "  ";                                            48310000
      byte pointer gpntr := @blank;                                     48315000
      integer i := 0;                                                   48320000
      byte array ftypes(0:29) = pb :=                                   48325000
         "TEXT LIST USL  MAST NEW  WKSP ";                     <<06130>>48330000
loop:                                                                   48335000
      if parm then                                                      48340000
      begin move fname(3) := ftypes(5*i) , (5);                         48345000
            xremjtentry(fname,gpntr,gpntr,3)                            48350000
      end;                                                              48355000
      parm := parm & lsr(1);                                            48360000
      i := i + 1;                                                       48365000
      if i < 6 then go to loop;                                <<06130>>48370000
end   <<delimpfile>>;                                                   48375000
$page   "MISC. COMMAND EXECUTORS -- JOB, HELLO,BYE ETC."                48380000
$control segment=cipreprun                                     <<04786>>48385000
procedure setstdlist(parmpoint,errptr,errornum,parmnum);       <<04786>>48390000
<<********************************************************>>   <<04786>>48395000
<<                                                        >>   <<04786>>48400000
<<  procedure name: setstdlist                            >>   <<04786>>48405000
<<  programmer: marie weston                              >>   <<04786>>48410000
<<  date: june 30, 1982                                   >>   <<04786>>48415000
<<                                                        >>   <<04786>>48420000
<<  parameters                                            >>   <<04786>>48425000
<<        parmpoint--on input, this is a pointer to the   >>   <<04786>>48430000
<<                   first character of the invoking sub- >>   <<04786>>48435000
<<                   string.  on output, this points to   >>   <<04786>>48440000
<<                   the delimiter following the invoking >>   <<04786>>48445000
<<                   substring.                           >>   <<04786>>48450000
<<                                                        >>   <<04786>>48455000
<<        errptr   --this pointer is undefined on input.  >>   <<04786>>48460000
<<                   in case of an error, this points to  >>   <<04786>>48465000
<<                   the offending byte in the parameter  >>   <<04786>>48470000
<<                   string on output.                    >>   <<04786>>48475000
<<                                                        >>   <<04786>>48480000
<<        errnum   --this integer is undefined on input.  >>   <<04786>>48485000
<<                   in case of an error, on output, this >>   <<04786>>48490000
<<                   will contain the ci error number, or,>>   <<04786>>48495000
<<                   if there is no error, it will contain>>   <<04786>>48500000
<<                   a zero.                              >>   <<04786>>48505000
<<                                                        >>   <<04786>>48510000
<<        parmnum  --this integer is incremented by two   >>   <<04786>>48515000
<<                   every time setstdlist is called to   >>   <<04786>>48520000
<<                   indicate that two parameters were    >>   <<04786>>48525000
<<                   processed.                           >>   <<04786>>48530000
<<                                                        >>   <<04786>>48535000
<<                                                        >>   <<04786>>48540000
<<  description:  this procedure executes the "STDLIST"   >>   <<04786>>48545000
<<    option of the "SET" command which is used to flag   >>   <<04786>>48550000
<<    the stdlist spoolfile for deletion or salvation     >>   <<04786>>48555000
<<    depending on the option specified.  the account     >>   <<04786>>48560000
<<    password bit in the first word of the jmat entry is >>   <<04786>>48565000
<<    used as the flag bit.                               >>   <<04786>>48570000
<<                                                        >>   <<04786>>48575000
<<********************************************************>>   <<04786>>48580000
                                                               <<04786>>48585000
                                                               <<04786>>48590000
  byte pointer parmpoint;                                      <<04786>>48595000
  byte pointer errptr;                                         <<04786>>48600000
  integer errornum,parmnum;                                    <<04786>>48605000
  option privileged,uncallable;                                <<*7882>>48610000
                                                               <<04786>>48615000
begin                                                          <<04786>>48620000
                                                               <<04786>>48625000
  equate                                                       <<04786>>48630000
    equals=0,                 <<  delimiter number         >>  <<04786>>48635000
    save=2,                                                    <<04786>>48640000
    delete=1,                                                  <<04786>>48645000
    reqparms=2;               <<  required number of parms >>  <<04786>>48650000
    intrinsic ffileinfo;                                       <<04786>>48655000
                                                               <<04786>>48660000
  integer                                                      <<04786>>48665000
    entryno,                  <<  dictionary entry number  >>  <<04786>>48670000
    temperr,                  <<  error during db exchange >>  <<04786>>48675000
    numparms,                 <<  for mycommand results    >>  <<04786>>48680000
    optionlen;                <<  length of stdlist option >>  <<04786>>48685000
                                                               <<04786>>48690000
  array qarray(*) = q+0;                                       <<06567>>48695000
  integer pcbglobloc;                                          <<06567>>48700000
                                                               <<06567>>48705000
  logical                                                      <<04786>>48710000
    ok,                       <<  flag for spooled status  >>  <<04786>>48715000
    status,                   <<  spooled status returned  >>  <<04786>>48720000
    savesir;                  <<  for return from getsir   >>  <<04786>>48725000
                                                               <<04786>>48730000
  <<          set up option dictionary                     >>  <<04786>>48735000
                                                               <<04786>>48740000
  byte array dict(0:1)=pb:=                                    <<04786>>48745000
    8,6,"DELETE",                                              <<04786>>48750000
    6,4,"SAVE",                                                <<04786>>48755000
    0;                                                         <<04786>>48760000
  equate dictlen=15;                                           <<04786>>48765000
  byte array localdict(0:dictlen-1);                           <<04786>>48770000
                                                               <<04786>>48775000
  <<          set up mycommand parameters                  >>  <<04786>>48780000
                                                               <<04786>>48785000
  double                                                       <<04786>>48790000
    dummy1,                                                    <<04786>>48795000
    dummy2,                                                    <<04786>>48800000
    dummy3;                                                    <<04786>>48805000
  double array newparms(*)=dummy1;                             <<04786>>48810000
  logical delimword=dummy1+1;                                  <<04786>>48815000
  logical optword=dummy2+1;                                    <<04786>>48820000
  define                                                       <<04786>>48825000
    delim=delimword.(11:5)#,                                   <<04786>>48830000
    parmlen=optword.(0:8)#;                                    <<04786>>48835000
  byte pointer optionptr=dummy2;                               <<04786>>48840000
  double ddl:=[8/"=",8/";",16/%6400]d;                         <<04786>>48845000
  byte array dl(*)=ddl;                                        <<04786>>48850000
                                                               <<06571>>48855000
<< ........................................................ >> <<06571>>48860000
<<     declarations for referencing the jmat                >> <<06571>>48865000
<<   jmatarr -- a db+0 array used to reference the jmat     >> <<06571>>48870000
<<              after an exchange db                        >> <<06571>>48875000
<<   jmatinx -- an index into the jmatarr to the correct    >> <<06571>>48880000
<<              entry.                                      >> <<06571>>48885000
<< ........................................................ >> <<06571>>48890000
                                                               <<06571>>48895000
   integer array jmatarr(*) = db+0;                            <<06571>>48900000
   integer       jmatinx;                                      <<06571>>48905000
                                                               <<06571>>48910000
                                                               <<04786>>48915000
<<                 set stdlist mainline                    >>  <<04786>>48920000
                                                               <<04786>>48925000
ok:=false;                                                     <<04786>>48930000
move localdict:=dict,(dictlen);                                <<04786>>48935000
mycommand(parmpoint,dl,reqparms,numparms,newparms);            <<04786>>48940000
optionlen:=parmlen;                                            <<04786>>48945000
entryno:=search(optionptr,optionlen,localdict);                <<04786>>48950000
                                                               <<04786>>48955000
<<           do syntax checking on parm string             >>  <<04786>>48960000
                                                               <<04786>>48965000
if delim<>equals then                                          <<04786>>48970000
  begin                                                        <<04786>>48975000
    @errptr:=@parmpoint+7;                                     <<04786>>48980000
    errornum:=no'equals;                                       <<04786>>48985000
  end                                                          <<04786>>48990000
else if entryno=0 then                                         <<04786>>48995000
  begin                                                        <<04786>>49000000
    @errptr:=@optionptr;                                       <<04786>>49005000
    errornum:=bad'option;                                      <<04786>>49010000
  end                                                          <<04786>>49015000
else                                                           <<04786>>49020000
                                                               <<04786>>49025000
<<    now check if process is a job with a spooled stdlist  >> <<04786>>49030000
                                                               <<04786>>49035000
  begin                                                        <<04786>>49040000
    temperr:=0;                                                <<04786>>49045000
    ffileinfo(2,38,status);                                    <<04786>>49050000
    if status <> 0 then                                        <<04786>>49055000
       ok:=true;                                               <<04786>>49060000
                                                               <<04786>>49065000
<<    get jmat index and lock the jmat                     >>  <<04786>>49070000
                                                               <<04786>>49075000
    pxglobal;                                                  <<06567>>49080000
    jmatinx  := pxg'jmatinx * jmatentrysize;                   <<06571>>49085000
    savesir := getsir(jmatsir);                                <<04786>>49090000
    exchangedb(jmatdst);                                       <<04786>>49095000
    if ok then                                                 <<04786>>49100000
                                                               <<04786>>49105000
<<   now check if the option is already in effect. if it   >>  <<04786>>49110000
<<   isn't then change the flag by complementing the bit.   >> <<04786>>49115000
                                                               <<04786>>49120000
      if (jmatsavestdlist=0 land entryno=save)                 <<06571>>49125000
                      lor                                      <<04786>>49130000
         (jmatsavestdlist=1 land entryno=delete)  then         <<06571>>49135000
         temperr:=-already                                     <<04786>>49140000
      else                                                     <<04786>>49145000
         jmatsavestdlist := jmatsavestdlist + 1                <<06571>>49150000
    else                                                       <<04786>>49155000
      temperr:=not'spooled;                                    <<04786>>49160000
                                                               <<04786>>49165000
<<  restore the old db and release the jmatsir        >>       <<04786>>49170000
                                                               <<04786>>49175000
    exchangedb(0);                                             <<04786>>49180000
    relsir(jmatsir,savesir);                                   <<04786>>49185000
    errornum:=temperr;                                         <<04786>>49190000
    @errptr:=@parmpoint;                                       <<04786>>49195000
  end;                                                         <<04786>>49200000
                                                               <<04786>>49205000
<<     move parmpoint to command delimiter                   >><<04786>>49210000
                                                               <<04786>>49215000
  @parmpoint:=@optionptr+optionlen;                            <<04786>>49220000
  scan parmpoint while "  ",1;                                 <<04786>>49225000
  @parmpoint:=tos;                                             <<04786>>49230000
                                                               <<04786>>49235000
<<     increment by number of parameters processed    >>       <<04786>>49240000
                                                               <<04786>>49245000
  parmnum:=parmnum+2;                                          <<04786>>49250000
end;                                                           <<04786>>49255000
                                                               <<04786>>49260000
$control segment=cipreprun                                     <<04786>>49265000
procedure cxset executorhead;                                  <<04786>>49270000
option privileged,uncallable;                                  <<*7882>>49275000
<<*********************************************************>>  <<04786>>49280000
<<                                                         >>  <<04786>>49285000
<<  procedure name: cxset                                  >>  <<04786>>49290000
<<  programmer: marie weston                               >>  <<04786>>49295000
<<  date: june 30, 1982                                    >>  <<04786>>49300000
<<                                                         >>  <<04786>>49305000
<<  description:  this procedure parses the "SET" command  >>  <<04786>>49310000
<<    parameter then calls the procedure needed to execute >>  <<04786>>49315000
<<    that command.  to add a new option to the command,   >>  <<04786>>49320000
<<    you must:                                            >>  <<04786>>49325000
<<       (1)  put the option name into the dictionary      >>  <<04786>>49330000
<<       (2)  increase the value of "DICTLEN" accordingly  >>  <<04786>>49335000
<<       (3)  put the procedure call into the case stmt    >>  <<04786>>49340000
<<                                                         >>  <<04786>>49345000
<<*********************************************************>>  <<04786>>49350000
                                                               <<04786>>49355000
  begin                                                        <<04786>>49360000
                                                               <<04786>>49365000
  byte array dict(0:1)=pb:=                                    <<04786>>49370000
    9,7,"STDLIST",                                             <<04786>>49375000
    0;                                                         <<04786>>49380000
  equate dictlen=10;                                           <<04786>>49385000
  byte array localdict(0:dictlen-1);                           <<04786>>49390000
  byte pointer                                                 <<04786>>49395000
    parmpoint,                    << points to current parm  >><<04786>>49400000
    errptr;                                                    <<04786>>49405000
                                                               <<04786>>49410000
  integer                                                      <<04786>>49415000
    entryno,                      << dictionary entry number >><<04786>>49420000
    errornum,                                                  <<04786>>49425000
    parmlen;                      << parameter length        >><<04786>>49430000
                                                               <<04786>>49435000
  logical                                                      <<04786>>49440000
    stillparse;                   << continue parsing flag   >><<04786>>49445000
                                                               <<04786>>49450000
  equate                                                       <<04786>>49455000
    cr=%15,                       << carriage return         >><<04786>>49460000
    semicol=";";                                               <<04786>>49465000
                                                               <<04786>>49470000
                                                               <<04786>>49475000
                                                               <<04786>>49480000
move localdict:=dict,(dictlen);                                <<04786>>49485000
@parmpoint:=@parmsp(0);                                        <<04786>>49490000
errornum:=0;                                                   <<04786>>49495000
stillparse:=true;                                              <<04786>>49500000
                                                               <<04786>>49505000
while stillparse do                                            <<04786>>49510000
  begin                                                        <<04786>>49515000
    parmnum:=parmnum+1;                                        <<04786>>49520000
    scan parmpoint while "  ",1;                               <<04786>>49525000
    @parmpoint := tos;                                         <<04786>>49530000
    if parmpoint<>alpha then                                   <<04786>>49535000
      begin                                                    <<04786>>49540000
        @errptr:=@parmpoint;                                   <<04786>>49545000
        errornum:=nonalpha;                                    <<04786>>49550000
      end                                                      <<04786>>49555000
    else                                                       <<04786>>49560000
      begin                                                    <<04786>>49565000
        move parmpoint:=parmpoint while ans,1;                 <<04786>>49570000
        parmlen:=tos-@parmpoint;                               <<04786>>49575000
        entryno:=search(parmpoint,parmlen,localdict);          <<04786>>49580000
        case entryno of                                        <<04786>>49585000
         begin                                                 <<04786>>49590000
                                                               <<04786>>49595000
           begin                     <<  option not found  >>  <<04786>>49600000
             @errptr:=@parmpoint;                              <<04786>>49605000
             errornum:=invalid'parm;                           <<04786>>49610000
           end;                                                <<04786>>49615000
                                                               <<04786>>49620000
           setstdlist(parmpoint,errptr,errornum,parmnum);      <<04786>>49625000
                                                               <<04786>>49630000
         end;                                                  <<04786>>49635000
                                                               <<04786>>49640000
<<    if command delimiter is a semicolon--continue parsing,>> <<04786>>49645000
<<    a cr: then stop parsing;  anything else is an error   >> <<04786>>49650000
                                                               <<04786>>49655000
        if (parmpoint=semicol) and (errornum=0)  then          <<04786>>49660000
           @parmpoint:=@parmpoint+1                            <<04786>>49665000
        else                                                   <<04786>>49670000
          if (parmpoint<>cr) and (errornum=0)  then            <<04786>>49675000
            begin                                              <<04786>>49680000
              @errptr:=@parmpoint;                             <<04786>>49685000
              errornum:=-unexp'delim;                          <<04786>>49690000
            end                                                <<04786>>49695000
          else                                                 <<04786>>49700000
            stillparse:=false;                                 <<04786>>49705000
      end;                                                     <<04786>>49710000
                                                               <<04786>>49715000
<<      take care of any errors                      >>        <<04786>>49720000
                                                               <<04786>>49725000
      if errornum<>0 then                                      <<04786>>49730000
        begin                                                  <<04786>>49735000
          errnum:=errornum;                                    <<04786>>49740000
          cierr(errnum,errptr);                                <<04786>>49745000
          if errnum>0 then                                     <<04786>>49750000
             return;                                           <<04786>>49755000
        end;                                                   <<04786>>49760000
                                                               <<04786>>49765000
  end;                                                         <<04786>>49770000
end;                                                           <<04786>>49775000
$control segment=cipreprun                                     <<u.rao>>49780000
      procedure cxsetmsg executorhead;                                  49785000
      option privileged,uncallable;                                     49790000
      begin                                                             49795000
double array parms(0:1)=q;                                     <<u.rao>>49800000
array qarray(*)=q+0;                                           <<06567>>49805000
integer pcbglobloc;                                            <<06567>>49810000
byte pointer bparm = parms;  <<pointer to argument>>           <<u.rao>>49815000
byte bparmlen = parms+1;     <<argument length>>               <<u.rao>>49820000
byte pointer extraparm = parms+2;                              <<u.rao>>49825000
double ddl := [8/",",8/";",16/%6400]d;                         <<u.rao>>49830000
byte array dl(*)=ddl;                                          <<u.rao>>49835000
integer numparms;                                              <<u.rao>>49840000
                                                               <<06571>>49845000
<< ........................................................ >> <<06571>>49850000
<<     declarations for referencing the jmat                >> <<06571>>49855000
<<   jmatarr -- a db+0 array used to reference the jmat     >> <<06571>>49860000
<<              after an exchange db                        >> <<06571>>49865000
<<   jmatinx -- an index into the jmatarr to the correct    >> <<06571>>49870000
<<              entry.                                      >> <<06571>>49875000
<< ........................................................ >> <<06571>>49880000
                                                               <<06571>>49885000
   integer array jmatarr(*) = db+0;                            <<06571>>49890000
   integer       jmatinx;                                      <<06571>>49895000
                                                               <<06571>>49900000
mycommand(parmsp,dl,2,numparms,parms);                         <<u.rao>>49905000
if numparms = 0 then   <<not enough parms>>                    <<u.rao>>49910000
   begin                                                       <<u.rao>>49915000
   cierr(errnum := setmsgparmprob, parmsp(1));                 <<u.rao>>49920000
   parmnum := 1;                                               <<u.rao>>49925000
   end                                                         <<u.rao>>49930000
else if numparms > 1 then  <<too many parms>>                  <<u.rao>>49935000
   begin                                                       <<u.rao>>49940000
   cierr(errnum := setmsgextraparm, extraparm);                <<u.rao>>49945000
   parmnum := 2;                                               <<u.rao>>49950000
   end                                                         <<u.rao>>49955000
else if (bparmlen=2) and (bparm="ON")                          <<u.rao>>49960000
     or (bparmlen=3) and (bparm="OFF") then                    <<u.rao>>49965000
   begin  <<have legal argument>>                              <<u.rao>>49970000
   pxglobal;                                                   <<06567>>49975000
   jmatinx := pxg'jmatinx * jmatentrysize;                     <<06571>>49980000
   exchangedb(jmatdst);                                        <<u.rao>>49985000
                                                               <<06571>>49990000
   <<  the following statement ends up setting the quiet bit >><<06571>>49995000
   <<  if bparmlen = 3.  if bparmlen = 2 it clears the bit   >><<06571>>50000000
                                                               <<06571>>50005000
   jmatquietmode := bparmlen;  << a cute trick >>              <<06571>>50010000
   exchangedb(0);                                              <<u.rao>>50015000
   end                                                         <<u.rao>>50020000
else  <<unknown argument>>                                     <<u.rao>>50025000
   begin                                                       <<u.rao>>50030000
   parmnum := 1;                                               <<u.rao>>50035000
   cierr(errnum := setmsgparmprob, bparm);                     <<u.rao>>50040000
   end;                                                        <<u.rao>>50045000
end;  <<cxsetmsg>>                                             <<u.rao>>50050000
      procedure setdump(flags);                                         50055000
      value flags;                                                      50060000
      logical flags;                                                    50065000
      begin                                                             50070000
      array qarray(*)=q+0;                                     <<06567>>50075000
      integer pcbglobloc;                                      <<06567>>50080000
      erroron;                                                          50085000
      pxglobal;                                                <<06567>>50090000
      flags.(10:1):=1;<<arm>>                                           50095000
      tos := if pxg'stkdumpflags <> 0 then 0 else 2;           <<06567>>50100000
      pxg'stkdumpflags := flags;                               <<06567>>50105000
      status.(6:2):=tos;<<set condition code>>                          50110000
      errorexit(1,0,0);                                                 50115000
      end;<<set dump>>                                                  50120000
      procedure resetdump;                                              50125000
      option privileged;                                                50130000
      begin                                                             50135000
      array qarray(*)=q+0;                                     <<06567>>50140000
      integer pcbglobloc;                                      <<06567>>50145000
      erroron;                                                          50150000
      pxglobal;                                                <<06567>>50155000
      tos := if pxg'stkdumpflags=0 then 0 else 2;              <<06567>>50160000
      pxg'stkdumpflags := 0;                                   <<06567>>50165000
      status.(6:2):=tos;                                                50170000
      errorexit(0,0,0);                                                 50175000
      end;<<reset dump>>                                                50180000
procedure cxsetdump executorhead;                              <<u.rao>>50185000
option privileged,uncallable;                                  <<u.rao>>50190000
begin                                                          <<u.rao>>50195000
integer pcnt:=0,  <<parm count>>                               <<u.rao>>50200000
        numparms,                                              <<u.rao>>50205000
        nextdelim,  <<delimiter found after current token>>    <<u.rao>>50210000
        plen;   <<length of current parm>>                     <<u.rao>>50215000
logical flags := %20;  <<template for dump flags>>             <<u.rao>>50220000
double array parms(0:4) = q;                                   <<u.rao>>50225000
byte pointer badparm = parms+8;                                <<u.rao>>50230000
byte pointer ppntr;  <<pointer to present token>>              <<u.rao>>50235000
double ddl := [8/",",8/";",16/%6400]d;                         <<u.rao>>50240000
byte array dl(*)=ddl;                                          <<u.rao>>50245000
equate dlen = 20;  <<length of dumptype array>>                <<u.rao>>50250000
byte array dumptypesl(0:dlen-1) = pb :=                        <<u.rao>>50255000
   4,2,"ST",                                                   <<u.rao>>50260000
   4,2,"DB",                                                   <<u.rao>>50265000
   4,2,"QS",                                                   <<u.rao>>50270000
   7,5,"ASCII",                                                <<u.rao>>50275000
   0;                                                          <<u.rao>>50280000
byte array dumptypes(0:dlen-1);                                <<u.rao>>50285000
                                                               <<u.rao>>50290000
subroutine getnextparm;                                        <<u.rao>>50295000
begin                                                          <<u.rao>>50300000
tos := parms(pcnt);                                            <<u.rao>>50305000
nextdelim := s0.(14:2);                                        <<u.rao>>50310000
plen := tos&lsr(8);                                            <<u.rao>>50315000
@ppntr := tos;                                                 <<u.rao>>50320000
end;                                                           <<u.rao>>50325000
                                                               <<u.rao>>50330000
subroutine synerr;  <<syntax error>>                           <<u.rao>>50335000
begin                                                          <<u.rao>>50340000
parmnum := pcnt+1;                                             <<u.rao>>50345000
ppntr(plen) := 0;                                              <<u.rao>>50350000
cierr(errnum := setdumpunknown,ppntr,0,@ppntr);                <<u.rao>>50355000
assemble(exit 3);  <<return>>                                  <<u.rao>>50360000
end;                                                           <<u.rao>>50365000
                                                               <<u.rao>>50370000
mycommand(parmsp,dl,5,numparms,parms);                         <<u.rao>>50375000
parmnum := 5;  <<max number of parms>>                         <<u.rao>>50380000
if numparms > 4 then                                           <<u.rao>>50385000
   cierr(errnum := setdump2mp,badparm)                         <<u.rao>>50390000
else  <<legal number of parms>>                                <<u.rao>>50395000
   begin                                                       <<u.rao>>50400000
   if numparms > 0 then                                        <<u.rao>>50405000
      begin  <<parse parms>>                                   <<u.rao>>50410000
      move dumptypes := dumptypesl, (dlen);  <<init search arra<<u.rao>>50415000
      do   <<loop through parms, identifying dump types>>      <<u.rao>>50420000
         begin                                                 <<u.rao>>50425000
         getnextparm;                                          <<u.rao>>50430000
         if plen <> 0 then  <<parm is present>>                <<u.rao>>50435000
            case search(ppntr, plen, dumptypes) of             <<u.rao>>50440000
               begin                                           <<u.rao>>50445000
               synerr;  <<non-existant type>>                  <<u.rao>>50450000
               flags.(14:1) := 1;  <<st>>                      <<u.rao>>50455000
               flags.(15:1) := 1;  <<db>>                      <<u.rao>>50460000
               flags.(13:1) := 1;  <<qs>>                      <<u.rao>>50465000
               begin                                           <<s8764>>50470000
                  flags.(11:1) := 0;  <<ascii>>                <<s8764>>50475000
                  flags.(12:1) := 1;  <<ascii bit>>            <<s8764>>50480000
               end;                                            <<s8764>>50485000
               end;                                            <<u.rao>>50490000
         pcnt := pcnt+1;                                       <<u.rao>>50495000
         end                                                   <<u.rao>>50500000
      until nextdelim=2;  <<until find cr delimiter>>          <<u.rao>>50505000
      end;                                                     <<u.rao>>50510000
   setdump(flags);                                             <<u.rao>>50515000
   end;                                                        <<u.rao>>50520000
end;  <<cxsetdump>>                                            <<u.rao>>50525000
procedure cxresetdump executorhead;                            <<u.rao>>50530000
option privileged, uncallable;                                 <<u.rao>>50535000
begin                                                          <<u.rao>>50540000
mycommand(parmsp,,0);                                          <<u.rao>>50545000
if <> then cierr(errnum := -warnxparmsignored,parmsp);         <<04785>>50550000
resetdump;                                                     <<u.rao>>50555000
end;                                                           <<u.rao>>50560000
$control list                                                           50565000
$page "MOVEJDT"                                                << 8499>>50570000
                                                               << 8499>>50575000
                                                               << 8499>>50580000
$control segment=cilistf                                       << 8499>>50585000
                                                               << 8499>>50590000
logical procedure movejdt( a );                                << 8765>>50595000
logical array a;                                               << 8765>>50600000
option uncallable;                                             << 8499>>50605000
comment:                                                       << 8499>>50610000
        this procedure fills a db relative array a             << 8499>>50615000
        with the contents of the job directory table.          << 8499>>50620000
        the jdt dst number is pulled from the stack ;          << 8765>>50625000
begin                                                          << 8499>>50630000
logical array qarray( * ) = q + 0;                             << 8765>>50635000
logical pcbglobloc := 0;                                       << 8765>>50640000
logical jdt'dst;                                               << 8499>>50645000
logical size;                                                  << 8765>>50650000
                                                               << 8499>>50655000
movejdt := true;  << assume success >>                         << 8499>>50660000
                                                               << 8499>>50665000
<< get the jdt dst number from the pxglobal area >>            << 8499>>50670000
                                                               << 8499>>50675000
<< we must retrieve the jdt dst number and move the dst >>     << 8499>>50680000
pxglobal;                                                      << 8765>>50685000
jdt'dst := pxg'jdtdst;                                         << 8765>>50690000
<< get the actual jdt length from the dst table >>             << 8765>>50695000
<< size of data segment size is divided by 4    >>             << 8765>>50700000
<< need to multiply size by 4.  entries of dst  >>             << 8765>>50705000
<< are 4 words long.                            >>             << 8765>>50710000
size := dst( jdt'dst * dst'entry'size ).dst'dseg'size;         << 8765>>50715000
tos := @a;                                                     << 8499>>50720000
tos := jdt'dst;                                                << 8499>>50725000
tos := 0;                                                      << 8499>>50730000
tos := size * 4;                                               << 8765>>50735000
assemble( mfds 4 );                                            << 8499>>50740000
end;                                                           << 8499>>50745000
$page "PARSELISTEQ"                                            << 8499>>50750000
                                                               << 8499>>50755000
                                                               << 8499>>50760000
<<******************************************************>>     << 8499>>50765000
<<                                                      >>     << 8499>>50770000
<<  procedure parselisteq                               >>     << 8499>>50775000
<<                                                      >>     << 8499>>50780000
<<  purpose:  to parse any parameters that are entered  >>     << 8499>>50785000
<<            with the listeq commnad.  all syntax      >>     << 8499>>50790000
<<            errors will be flagged in this procedure. >>     << 8499>>50795000
<<            at this time, the maximum number of       >>     << 8499>>50800000
<<            parameters is 2.  the syntax of the       >>     << 8499>>50805000
<<            command is :listeq [listfile]             >>     << 8499>>50810000
<<                                                      >>     << 8499>>50815000
<<******************************************************>>     << 8499>>50820000
logical procedure parselisteq( parmpoint, listlen, listfile ); << 8499>>50825000
byte pointer parmpoint;                                        << 8499>>50830000
integer listlen;                                               << 8499>>50835000
byte pointer listfile;                                         << 8499>>50840000
option uncallable;                                             << 8499>>50845000
                                                               << 8499>>50850000
<<*************************************************************<< 8499>>50855000
<<                                                             << 8499>>50860000
<< parmpoint - byte pointer to the start of the parameter strin<< 8499>>50865000
<< listlen   - the length of the byte string depicting the list<< 8499>>50870000
<<             file parameter.  if zero, the list file did not << 8499>>50875000
<<             exist in the paramter list.                     << 8499>>50880000
<< listfile  - byte pointer to the listfile.                   << 8499>>50885000
<<                                                             << 8499>>50890000
<<*************************************************************<< 8499>>50895000
                                                               << 8499>>50900000
<<   now set up all the mycommand parameters and those     >>  << 8499>>50905000
<<   needed to parse the command                           >>  << 8499>>50910000
                                                               << 8499>>50915000
begin                                                          << 8499>>50920000
double array dparms(0:1)=q;  << make room for 2 parms.  one for<< 8499>>50925000
                             << listfile and one for error     << 8499>>50930000
integer array parms(*)=dparms;                                 << 8499>>50935000
logical parseok = parselisteq;                                 << 8499>>50940000
<<                                                           >><< 8499>>50945000
<< the break down of parms is as follows:                    >><< 8499>>50950000
<<     parms(0) - byte pointer for parameter 1.              >><< 8499>>50955000
<<     parms(1) - parameter 1 information                    >><< 8499>>50960000
<<     parms(2) - byte pointer for parameter 2.              >><< 8499>>50965000
<<     parms(3) - parameter 2 information.                   >><< 8499>>50970000
<<                                                           >><< 8499>>50975000
                                                               << 8499>>50980000
define                                                         << 8499>>50985000
  parm1'len            = parms(1).(0:8)#,                      << 8499>>50990000
  parm2'len            = parms(3).(0:8)#,                      << 8499>>50995000
  delim'for'parm1      = parms(1).(11:5)#,                     << 8499>>51000000
  delim'for'parm2      = parms(3).(11:5)#;                     << 8499>>51005000
                                                               << 8499>>51010000
byte pointer parm1, parm2, iptr;                               << 8499>>51015000
integer icheck;  << used in subroutine checkit >>              << 8499>>51020000
                                                               << 8499>>51025000
byte pointer errptr;                                           << 8499>>51030000
                                                               << 8499>>51035000
double rdl := [16/%6400,16/%6400]d;                            << 8499>>51040000
byte array rl(*) = rdl;                                        << 8499>>51045000
                                                               << 8499>>51050000
double ddl := [8/".",8/",",16/%6400]d;                         << 8499>>51055000
byte array dl(*) = ddl;                                        << 8499>>51060000
                                                               << 8499>>51065000
equate dot                = 0,                                 << 8499>>51070000
       comma              = 1,                                 << 8499>>51075000
       cr                 = 2,                                 << 8499>>51080000
       maxparms           = 1, << the [listfile]          >>   << 8499>>51085000
       max'name'len       = 8,                                 << 8499>>51090000
       good               = 0,                                 << 8499>>51095000
       file'name'two'long = 1,                                 << 8499>>51100000
       first'char'bad     = 2,                                 << 8499>>51105000
       funny'char         = 3,                                 << 8499>>51110000
       imb'blk            = 4,                                 << 8499>>51115000
       zero'len           = 5;                                 << 8499>>51120000
                                                               << 8499>>51125000
                                                               << 8499>>51130000
                                                               << 8499>>51135000
integer numparms, checkf, errornum;                            << 8499>>51140000
byte wild    := "@",                                           << 8499>>51145000
     star    := "*",                                           << 8499>>51150000
     num     := "#",                                           << 8499>>51155000
     single  := "?",                                           << 8499>>51160000
     car'ret := %15,                                           << 8499>>51165000
     space   := " ";                                           << 8499>>51170000
$page                                                          << 8499>>51175000
                                                               << 8499>>51180000
<<************************************************************><< 8499>>51185000
<<                                                            ><< 8499>>51190000
<< subroutine good'file                                       ><< 8499>>51195000
<<                                                            ><< 8499>>51200000
<< purpose:  calls external procedure cibadfilename to        ><< 8499>>51205000
<<           determine if the list file represented by parm2  ><< 8499>>51210000
<<           is in a legal mpe file system form.  if not,     ><< 8499>>51215000
<<           good'file returns false.                         ><< 8499>>51220000
<<                                                            ><< 8499>>51225000
<<************************************************************><< 8499>>51230000
                                                               << 8499>>51235000
logical subroutine good'file( d'file );                        << 8499>>51240000
                                                               << 8499>>51245000
<<***********************************************************>><< 8499>>51250000
<<                                                           >><< 8499>>51255000
<< d'file - a double array element (as returned from         >><< 8499>>51260000
<<          mycommand) used by cibadfilename.                >><< 8499>>51265000
<<                                                           >><< 8499>>51270000
<<***********************************************************>><< 8499>>51275000
double array d'file;                                           << 8499>>51280000
                                                               << 8499>>51285000
begin                                                          << 8499>>51290000
good'file := true;                                             << 8499>>51295000
if cibadfilename( errornum, d'file )                           << 8499>>51300000
   then good'file := false;                                    << 8499>>51305000
end;    << good'file >>                                        << 8499>>51310000
                                                               << 8499>>51315000
$page                                                          << 8499>>51320000
<<                   m a i n   b o d y                  >>     << 8499>>51325000
                                                               << 8499>>51330000
parselisteq := true;          << assume success >>             << 8499>>51335000
                                                               << 8499>>51340000
listlen := 0;                                                  << 8499>>51345000
parms(0) := 0;                                                 << 8499>>51350000
move parms(1) := parms(0),(3);                                 << 8499>>51355000
                                                               << 8499>>51360000
<< attempt to get the [listfile] and then check for any other ><< 8499>>51365000
<< parameters.  if other parameters are found, flag them.     ><< 8499>>51370000
mycommand( parmpoint, rl, maxparms, numparms, dparms);         << 8499>>51375000
                                                               << 8499>>51380000
@parm1:=parms(0);                                              << 8499>>51385000
@parm2:=parms(2);                                              << 8499>>51390000
                                                               << 8499>>51395000
                                                               << 8499>>51400000
if numparms > 0                                                << 8499>>51405000
   then if good'file( dparms(0) )                              << 8499>>51410000
           then begin                                          << 8499>>51415000
                listlen := parm1'len;                          << 8499>>51420000
                @listfile := @parm1;                           << 8499>>51425000
                end                                            << 8499>>51430000
           else parselisteq := false;                          << 8499>>51435000
                                                               << 8499>>51440000
                                                               << 8499>>51445000
end;   << procedure parselisteq >>                             << 8499>>51450000
                                                               << 8499>>51455000
                                                               << 8499>>51460000
$page "LISTEQ"                                                 << 8499>>51465000
$control segment=cilistf                                       << 8499>>51470000
procedure cxlisteq executorhead;                               << 8499>>51475000
option privileged,uncallable;                                  << 8499>>51480000
begin                                                          << 8499>>51485000
                                                               << 8499>>51490000
<<***********************************************************>><< 8499>>51495000
<<                                                           >><< 8499>>51500000
<< cxlisteq: command executor for the listeq command.        >><< 8499>>51505000
<<                                                           >><< 8499>>51510000
<< the syntax is :listeq [listfile]                          >><< 8499>>51515000
<<                                                           >><< 8499>>51520000
<< where:                                                    >><< 8499>>51525000
<<       listfile is any file or back-referenced file to     >><< 8499>>51530000
<<          the output will be deposited.  default is        >><< 8499>>51535000
<<          $stdlist.                                        >><< 8499>>51540000
<<                                                           >><< 8499>>51545000
<<***********************************************************>><< 8499>>51550000
                                                               << 8499>>51555000
                                                               << 8499>>51560000
define                                                         << 8499>>51565000
   turnofftraps = push( status );                              << 8499>>51570000
                  tos.(2:1) := 0;                              << 8499>>51575000
                  set( status )#;                              << 8499>>51580000
                                                               << 8499>>51585000
equate jdt'len     = jdt'max'len,                              << 8499>>51590000
       forms'type  = 0,                                        << 8499>>51595000
       tape'label  = 1;                                        << 8499>>51600000
                                                               << 8499>>51605000
byte space  := " ";                                            << 8499>>51610000
                                                               << 8499>>51615000
logical array jdtarr( 0:jdt'len - 1 );                         << 8499>>51620000
                                                               << 8499>>51625000
<< logical pointers for moving through feq entries >>          << 8499>>51630000
logical pointer                                                << 8499>>51635000
                temp'feq,    << temporary pointer >>           << 8499>>51640000
                save'feq'entry, << saves feq'entry/feq >>      << 8499>>51645000
                feq'head, << points to start of feq table >>   << 8499>>51650000
                feq'entry,<< points to top of feq entry   >>   << 8499>>51655000
                feq'tail; << points to end of feq table >>     << 8499>>51660000
                                                               << 8499>>51665000
integer feq'words,       << number of words/feq entry    >>    << 8499>>51670000
        feq'fname'size,  << number words/formal desig    >>    << 8499>>51675000
        feq'aname'size,  << number bytes/actual fname    >>    << 8499>>51680000
        feq'dname'size;  << number bytes/dev #/classname >>    << 8499>>51685000
                                                               << 8499>>51690000
integer ob'index;  << index into out'buff for next string  >>  << 8499>>51695000
                                                               << 8499>>51700000
logical array out'buff'l(0:127); << to print final feq   >>    << 8499>>51705000
byte    array out'buff(*) = out'buff'l; << holds budding feq >><< 8499>>51710000
                                                               << 8499>>51715000
logical complete := true,                                      << 8499>>51720000
        foptions := 0,                                         << 8499>>51725000
        aoptions := 0,                                         << 8499>>51730000
        jir      := 0,                                         << 8499>>51735000
        pmask1   := 0,                                         << 8499>>51740000
        pmask2   := 0;                                         << 8499>>51745000
                                                               << 8499>>51750000
byte    array realnamea(0:35);                                 << 8499>>51755000
byte pointer realname := @realnamea;                           << 8499>>51760000
                                                               << 8499>>51765000
logical array file'name'l(0:35);                               << 8499>>51770000
byte    array file'name(*) = file'name'l;                      << 8499>>51775000
                                                               << 8499>>51780000
byte pointer parmpoint,                                        << 8499>>51785000
             devname,                                          << 8499>>51790000
             keywords,                                         << 8499>>51795000
             form,                                             << 8499>>51800000
             l'f'name,                                         << 8499>>51805000
             label'f,                                          << 8499>>51810000
             b2,                                               << 8499>>51815000
             eof,                                              << 8499>>51820000
             filename;     << ptr to various names in feq >>   << 8499>>51825000
                                                               << 8499>>51830000
integer file'num,                                              << 8499>>51835000
        error'parm,                                            << 8499>>51840000
        i,                                                     << 8499>>51845000
        devpart,                                               << 8499>>51850000
        keypart,                                               << 8499>>51855000
        which,                                                 << 8499>>51860000
        label'length,                                          << 8499>>51865000
        l'f'len;                                               << 8499>>51870000
                                                               << 8499>>51875000
double pointer file'size;                                      << 8499>>51880000
                                                               << 8499>>51885000
byte array temp(0:80);                                         << 8499>>51890000
<<                                                           >><< 8499>>51895000
<< the following equates are used primarily as indexes into  >><< 8499>>51900000
<< a formatting case statement that is used to print the     >><< 8499>>51905000
<< appropriate keywords, etc.                                >><< 8499>>51910000
<<                                                           >><< 8499>>51915000
                                                               << 8499>>51920000
equate                                                         << 8499>>51925000
     cr           = %15,                                       << 8499>>51930000
     file'        = 2,                                         << 8499>>51935000
     semi'colon   = 3,                                         << 8499>>51940000
     comma        = 4,                                         << 8499>>51945000
     equals       = 5,                                         << 8499>>51950000
     stdlist      = 6,                                         << 8499>>51955000
     newpass      = 7,                                         << 8499>>51960000
     oldpass      = 8,                                         << 8499>>51965000
     stdin        = 9,                                         << 8499>>51970000
     stdinx       = 10,                                        << 8499>>51975000
     null         = 11,                                        << 8499>>51980000
     fixed        = 12,                                        << 8499>>51985000
     variable'    = 13,                                        << 8499>>51990000
     undefined    = 14,                                        << 8499>>51995000
     new          = 15,                                        << 8499>>52000000
     old          = 16,                                        << 8499>>52005000
     oldtemp      = 17,                                        << 8499>>52010000
     dev          = 18,                                        << 8499>>52015000
     disc         = 19,                                        << 8499>>52020000
     nobuf        = 20,                                        << 8499>>52025000
     cctl         = 21,                                        << 8499>>52030000
     mr           = 22,                                        << 8499>>52035000
     exc          = 23,                                        << 8499>>52040000
     semi         = 24,                                        << 8499>>52045000
     shr          = 25,                                        << 8499>>52050000
     acc          = 26,                                        << 8499>>52055000
     buf          = 27,                                        << 8499>>52060000
     del'         = 28,                                        << 8499>>52065000
     save         = 29,                                        << 8499>>52070000
     temp'        = 30,                                        << 8499>>52075000
     code         = 31,                                        << 8499>>52080000
     binary'      = 32,                                        << 8499>>52085000
     ascii'       = 33,                                        << 8499>>52090000
     rec          = 34,                                        << 8499>>52095000
     star         = 35,                                        << 8499>>52100000
     in           = 36,                                        << 8499>>52105000
     out          = 37,                                        << 8499>>52110000
     outkeep      = 38,                                        << 8499>>52115000
     append       = 39,                                        << 8499>>52120000
     inout        = 40,                                        << 8499>>52125000
     update       = 41,                                        << 8499>>52130000
     fail'on'jdt  = 42,                                        << 8499>>52135000
     nolabel      = 43,                                        << 8499>>52140000
     label'       = 44,                                        << 8499>>52145000
     ksam'        = 45,                                        << 8499>>52150000
     forms        = 46,                                        << 8499>>52155000
     lock         = 47,                                        << 8499>>52160000
     nolock       = 48,                                        << 8499>>52165000
     nocctl       = 49,                                        << 8499>>52170000
     nomr         = 50,                                        << 8499>>52175000
     multi        = 51,                                        << 8499>>52180000
     nomulti      = 52,                                        << 8499>>52185000
     wait         = 53,                                        << 8499>>52190000
     nowait       = 54,                                        << 8499>>52195000
     gmulti       = 55,                                        << 8499>>52200000
     std          = 56,                                        << 8499>>52205000
     rio          = 57,                                        << 8499>>52210000
     msg          = 58,                                        << 8499>>52215000
     cir          = 59,                                        << 8499>>52220000
     copy         = 60,                                        << 8499>>52225000
     nocopy       = 61,                                        << 8499>>52230000
     vterm        = 62,                                        << 8499>>52235000
     dummy1       = 999;                                       << 8499>>52240000
$page                                                          << 8499>>52245000
                                                               << 8499>>52250000
                                                               << 8499>>52255000
intrinsic fopen,fwrite,ascii,dascii;                           << 8499>>52260000
                                                               << 8499>>52265000
<<*************************************************************<< 8499>>52270000
<<                                                             << 8499>>52275000
<< subroutine load'string                                      << 8499>>52280000
<<                                                             << 8499>>52285000
<< purpose - to load a string constant into a byte array       << 8499>>52290000
<<           out'buff( ob'index ) and increment ob'index by    << 8499>>52295000
<<           the length of the string                          << 8499>>52300000
<<                                                             << 8499>>52305000
<<*************************************************************<< 8499>>52310000
                                                               << 8499>>52315000
subroutine load'string( index );                               << 8499>>52320000
 value index;                                                  << 8499>>52325000
 integer index;                                                << 8499>>52330000
                                                               << 8499>>52335000
<<*************************************************************<< 8499>>52340000
<<                                                             << 8499>>52345000
<< index - an integer that is an index to a case statement     << 8499>>52350000
<<         that represents the string to be placed in out'buff << 8499>>52355000
<<                                                             << 8499>>52360000
<<*************************************************************<< 8499>>52365000
begin                                                          << 8499>>52370000
                                                               << 8499>>52375000
case index of                                                  << 8499>>52380000
     begin                                                     << 8499>>52385000
     << 0 >>                                                   << 8499>>52390000
     ;                                                         << 8499>>52395000
                                                               << 8499>>52400000
     << 1 >>                                                   << 8499>>52405000
     ;                                                         << 8499>>52410000
                                                               << 8499>>52415000
     << 2 >>                                                   << 8499>>52420000
     begin                                                     << 8499>>52425000
     move out'buff( ob'index ) := " FILE ";                    << 8499>>52430000
     ob'index := ob'index + 6;                                 << 8499>>52435000
     end;                                                      << 8499>>52440000
                                                               << 8499>>52445000
     << 3 >>                                                   << 8499>>52450000
     begin                                                     << 8499>>52455000
     move out'buff( ob'index ) := ";";                         << 8499>>52460000
     ob'index := ob'index + 1;                                 << 8499>>52465000
     end;                                                      << 8499>>52470000
                                                               << 8499>>52475000
     << 4 >>                                                   << 8499>>52480000
     begin                                                     << 8499>>52485000
     move out'buff( ob'index ) := ",";                         << 8499>>52490000
     ob'index := ob'index + 1;                                 << 8499>>52495000
     end;                                                      << 8499>>52500000
                                                               << 8499>>52505000
     << 5 >>                                                   << 8499>>52510000
     begin                                                     << 8499>>52515000
     move out'buff( ob'index ) := "=";                         << 8499>>52520000
     ob'index := ob'index +  1;                                << 8499>>52525000
     end;                                                      << 8499>>52530000
                                                               << 8499>>52535000
     << 6 >>                                                   << 8499>>52540000
     begin                                                     << 8499>>52545000
     move out'buff( ob'index ) := "=$STDLIST";                 << 8499>>52550000
     ob'index := ob'index +  10;                               << 8499>>52555000
     end;                                                      << 8499>>52560000
                                                               << 8499>>52565000
     << 7 >>                                                   << 8499>>52570000
     begin                                                     << 8499>>52575000
     move out'buff( ob'index ) := "=$NEWPASS";                 << 8499>>52580000
     ob'index := ob'index +  9;                                << 8499>>52585000
     end;                                                      << 8499>>52590000
                                                               << 8499>>52595000
     << 8 >>                                                   << 8499>>52600000
     begin                                                     << 8499>>52605000
     move out'buff( ob'index ) := "=$OLDPASS";                 << 8499>>52610000
     ob'index := ob'index +  9;                                << 8499>>52615000
     end;                                                      << 8499>>52620000
                                                               << 8499>>52625000
     << 9 >>                                                   << 8499>>52630000
     begin                                                     << 8499>>52635000
     move out'buff( ob'index ) := "=$STDIN";                   << 8499>>52640000
     ob'index := ob'index + 7;                                 << 8499>>52645000
     end;                                                      << 8499>>52650000
                                                               << 8499>>52655000
     << 10 >>                                                  << 8499>>52660000
     begin                                                     << 8499>>52665000
     move out'buff( ob'index ) := "=$STDINX";                  << 8499>>52670000
     ob'index := ob'index + 8;                                 << 8499>>52675000
     end;                                                      << 8499>>52680000
                                                               << 8499>>52685000
     << 11 >>                                                  << 8499>>52690000
     begin                                                     << 8499>>52695000
     move out'buff( ob'index ) := "=$NULL";                    << 8499>>52700000
     ob'index := ob'index + 6;                                 << 8499>>52705000
     end;                                                      << 8499>>52710000
                                                               << 8499>>52715000
     << 12 >>                                                  << 8499>>52720000
     begin                                                     << 8499>>52725000
     move out'buff( ob'index ) := "F";                         << 8499>>52730000
     ob'index := ob'index + 1;                                 << 8499>>52735000
     end;                                                      << 8499>>52740000
                                                               << 8499>>52745000
     << 13 >>                                                  << 8499>>52750000
     begin                                                     << 8499>>52755000
     move out'buff( ob'index ) := "V";                         << 8499>>52760000
     ob'index := ob'index + 1;                                 << 8499>>52765000
     end;                                                      << 8499>>52770000
                                                               << 8499>>52775000
     << 14 >>                                                  << 8499>>52780000
     begin                                                     << 8499>>52785000
     move out'buff( ob'index ) := "U";                         << 8499>>52790000
     ob'index := ob'index + 1;                                 << 8499>>52795000
     end;                                                      << 8499>>52800000
                                                               << 8499>>52805000
     << 15 >>                                                  << 8499>>52810000
     begin                                                     << 8499>>52815000
     move out'buff( ob'index ) := ",NEW";                      << 8499>>52820000
     ob'index := ob'index + 4;                                 << 8499>>52825000
     end;                                                      << 8499>>52830000
                                                               << 8499>>52835000
     << 16 >>                                                  << 8499>>52840000
     begin                                                     << 8499>>52845000
     move out'buff( ob'index ) := ",OLD";                      << 8499>>52850000
     ob'index := ob'index +  4;                                << 8499>>52855000
     end;                                                      << 8499>>52860000
                                                               << 8499>>52865000
     << 17 >>                                                  << 8499>>52870000
     begin                                                     << 8499>>52875000
     move out'buff( ob'index ) := ",OLDTEMP";                  << 8499>>52880000
     ob'index := ob'index + 8;                                 << 8499>>52885000
     end;                                                      << 8499>>52890000
                                                               << 8499>>52895000
     << 18 >>                                                  << 8499>>52900000
     begin                                                     << 8499>>52905000
     move out'buff( ob'index ) := ";DEV=";                     << 8499>>52910000
     ob'index := ob'index + 5;                                 << 8499>>52915000
     end;                                                      << 8499>>52920000
                                                               << 8499>>52925000
     << 19 >>                                                  << 8499>>52930000
     begin                                                     << 8499>>52935000
     move out'buff( ob'index ) := ";DISC=";                    << 8499>>52940000
     ob'index := ob'index + 6;                                 << 8499>>52945000
     end;                                                      << 8499>>52950000
                                                               << 8499>>52955000
     << 20 >>                                                  << 8499>>52960000
     begin                                                     << 8499>>52965000
     move out'buff( ob'index ) := ";NOBUF";                    << 8499>>52970000
     ob'index := ob'index + 6;                                 << 8499>>52975000
     end;                                                      << 8499>>52980000
                                                               << 8499>>52985000
     << 21 >>                                                  << 8499>>52990000
     begin                                                     << 8499>>52995000
     move out'buff( ob'index ) := ";CCTL";                     << 8499>>53000000
     ob'index := ob'index + 5;                                 << 8499>>53005000
     end;                                                      << 8499>>53010000
                                                               << 8499>>53015000
     << 22 >>                                                  << 8499>>53020000
     begin                                                     << 8499>>53025000
     move out'buff( ob'index ) := ";MR";                       << 8499>>53030000
     ob'index := ob'index + 3;                                 << 8499>>53035000
     end;                                                      << 8499>>53040000
                                                               << 8499>>53045000
     << 23 >>                                                  << 8499>>53050000
     begin                                                     << 8499>>53055000
     move out'buff( ob'index ) := ";EXC";                      << 8499>>53060000
     ob'index := ob'index + 4;                                 << 8499>>53065000
     end;                                                      << 8499>>53070000
                                                               << 8499>>53075000
     << 24 >>                                                  << 8499>>53080000
     begin                                                     << 8499>>53085000
     move out'buff( ob'index ) := ";SEMI";                     << 8499>>53090000
     ob'index := ob'index + 5;                                 << 8499>>53095000
     end;                                                      << 8499>>53100000
                                                               << 8499>>53105000
     << 25 >>                                                  << 8499>>53110000
     begin                                                     << 8499>>53115000
     move out'buff( ob'index ) := ";SHR";                      << 8499>>53120000
     ob'index := ob'index + 4;                                 << 8499>>53125000
     end;                                                      << 8499>>53130000
                                                               << 8499>>53135000
     << 26 >>                                                  << 8499>>53140000
     begin                                                     << 8499>>53145000
     move out'buff( ob'index ) := ";ACC=";                     << 8499>>53150000
     ob'index := ob'index + 5;                                 << 8499>>53155000
     end;                                                      << 8499>>53160000
                                                               << 8499>>53165000
     << 27 >>                                                  << 8499>>53170000
     begin                                                     << 8499>>53175000
     move out'buff( ob'index ) := ";BUF=";                     << 8499>>53180000
     ob'index := ob'index + 5;                                 << 8499>>53185000
     end;                                                      << 8499>>53190000
                                                               << 8499>>53195000
     << 28 >>                                                  << 8499>>53200000
     begin                                                     << 8499>>53205000
     move out'buff( ob'index ) := ";DEL";                      << 8499>>53210000
     ob'index := ob'index + 4;                                 << 8499>>53215000
     end;                                                      << 8499>>53220000
                                                               << 8499>>53225000
     << 29 >>                                                  << 8499>>53230000
     begin                                                     << 8499>>53235000
     move out'buff( ob'index ) := ";SAVE";                     << 8499>>53240000
     ob'index := ob'index + 5;                                 << 8499>>53245000
     end;                                                      << 8499>>53250000
                                                               << 8499>>53255000
     << 30 >>                                                  << 8499>>53260000
     begin                                                     << 8499>>53265000
     move out'buff( ob'index ) := ";TEMP";                     << 8499>>53270000
     ob'index := ob'index + 5;                                 << 8499>>53275000
     end;                                                      << 8499>>53280000
                                                               << 8499>>53285000
     << 31 >>                                                  << 8499>>53290000
     begin                                                     << 8499>>53295000
     move out'buff( ob'index ) := ";CODE=";                    << 8499>>53300000
     ob'index := ob'index + 6;                                 << 8499>>53305000
     end;                                                      << 8499>>53310000
                                                               << 8499>>53315000
     << 32 >>                                                  << 8499>>53320000
     begin                                                     << 8499>>53325000
     move out'buff( ob'index ) := ",BINARY";                   << 8499>>53330000
     ob'index := ob'index + 7;                                 << 8499>>53335000
     end;                                                      << 8499>>53340000
                                                               << 8499>>53345000
     << 33 >>                                                  << 8499>>53350000
     begin                                                     << 8499>>53355000
     move out'buff( ob'index ) := ",ASCII";                    << 8499>>53360000
     ob'index := ob'index + 6;                                 << 8499>>53365000
     end;                                                      << 8499>>53370000
                                                               << 8499>>53375000
     << 34 >>                                                  << 8499>>53380000
     begin                                                     << 8499>>53385000
     move out'buff( ob'index ) := ";REC=";                     << 8499>>53390000
     ob'index := ob'index +  5;                                << 8499>>53395000
     end;                                                      << 8499>>53400000
                                                               << 8499>>53405000
     << 35 >>                                                  << 8499>>53410000
     begin                                                     << 8499>>53415000
     move out'buff( ob'index ) := "*";                         << 8499>>53420000
     ob'index := ob'index + 1;                                 << 8499>>53425000
     end;                                                      << 8499>>53430000
                                                               << 8499>>53435000
     << 36 >>                                                  << 8499>>53440000
     begin                                                     << 8499>>53445000
     move out'buff( ob'index ) := "IN";                        << 8499>>53450000
     ob'index := ob'index + 2;                                 << 8499>>53455000
     end;                                                      << 8499>>53460000
                                                               << 8499>>53465000
     << 37 >>                                                  << 8499>>53470000
     begin                                                     << 8499>>53475000
     move out'buff( ob'index ) := "OUT";                       << 8499>>53480000
     ob'index := ob'index + 3;                                 << 8499>>53485000
     end;                                                      << 8499>>53490000
                                                               << 8499>>53495000
     << 38 >>                                                  << 8499>>53500000
     begin                                                     << 8499>>53505000
     move out'buff( ob'index ) := "OUTKEEP";                   << 8499>>53510000
     ob'index := ob'index + 7;                                 << 8499>>53515000
     end;                                                      << 8499>>53520000
                                                               << 8499>>53525000
     << 39 >>                                                  << 8499>>53530000
     begin                                                     << 8499>>53535000
     move out'buff( ob'index ) := "APPEND";                    << 8499>>53540000
     ob'index := ob'index + 6;                                 << 8499>>53545000
     end;                                                      << 8499>>53550000
                                                               << 8499>>53555000
     << 40 >>                                                  << 8499>>53560000
     begin                                                     << 8499>>53565000
     move out'buff( ob'index ) := "INOUT";                     << 8499>>53570000
     ob'index := ob'index + 5;                                 << 8499>>53575000
     end;                                                      << 8499>>53580000
                                                               << 8499>>53585000
     << 41 >>                                                  << 8499>>53590000
     begin                                                     << 8499>>53595000
     move out'buff( ob'index ) := "UPDATE";                    << 8499>>53600000
     ob'index := ob'index + 6;                                 << 8499>>53605000
     end;                                                      << 8499>>53610000
                                                               << 8499>>53615000
     << 42 >>                                                  << 8499>>53620000
     begin                                                     << 8499>>53625000
     move out'buff( ob'index ) := "FAILURE TO GET JDT";        << 8499>>53630000
     ob'index := ob'index + 18;                                << 8499>>53635000
     end;                                                      << 8499>>53640000
                                                               << 8499>>53645000
     << 43 >>                                                  << 8499>>53650000
     begin                                                     << 8499>>53655000
     move out'buff( ob'index ) := ";NOLABEL";                  << 8499>>53660000
     ob'index := ob'index + 9;                                 << 8499>>53665000
     end;                                                      << 8499>>53670000
                                                               << 8499>>53675000
     << 44 >>                                                  << 8499>>53680000
     begin                                                     << 8499>>53685000
     move out'buff( ob'index ) := ";LABEL";                    << 8499>>53690000
     ob'index := ob'index + 6;                                 << 8499>>53695000
     end;                                                      << 8499>>53700000
                                                               << 8499>>53705000
     << 45 >>                                                  << 8499>>53710000
     begin                                                     << 8499>>53715000
     move out'buff( ob'index ) := ";KSAM";                     << 8499>>53720000
     ob'index := ob'index + 5;                                 << 8499>>53725000
     end;                                                      << 8499>>53730000
                                                               << 8499>>53735000
     << 46 >>                                                  << 8499>>53740000
     begin                                                     << 8499>>53745000
     move out'buff( ob'index ) := ";FORMS";                    << 8499>>53750000
     ob'index := ob'index + 6;                                 << 8499>>53755000
     end;                                                      << 8499>>53760000
                                                               << 8499>>53765000
     << 47 >>                                                  << 8499>>53770000
     begin                                                     << 8499>>53775000
     move out'buff( ob'index ) := ";LOCK";                     << 8499>>53780000
     ob'index := ob'index + 5;                                 << 8499>>53785000
     end;                                                      << 8499>>53790000
                                                               << 8499>>53795000
     << 48 >>                                                  << 8499>>53800000
     begin                                                     << 8499>>53805000
     move out'buff( ob'index ) := ";NOLOCK";                   << 8499>>53810000
     ob'index := ob'index + 7;                                 << 8499>>53815000
     end;                                                      << 8499>>53820000
                                                               << 8499>>53825000
     << 49 >>                                                  << 8499>>53830000
     begin                                                     << 8499>>53835000
     move out'buff( ob'index ) := ";NOCCTL";                   << 8499>>53840000
     ob'index := ob'index + 7;                                 << 8499>>53845000
     end;                                                      << 8499>>53850000
                                                               << 8499>>53855000
     << 50 >>                                                  << 8499>>53860000
     begin                                                     << 8499>>53865000
     move out'buff( ob'index ) := ";NOMR";                     << 8499>>53870000
     ob'index := ob'index + 5;                                 << 8499>>53875000
     end;                                                      << 8499>>53880000
                                                               << 8499>>53885000
     << 51 >>                                                  << 8499>>53890000
     begin                                                     << 8499>>53895000
     move out'buff( ob'index ) := ";MULTI";                    << 8499>>53900000
     ob'index := ob'index + 6;                                 << 8499>>53905000
     end;                                                      << 8499>>53910000
                                                               << 8499>>53915000
     << 52 >>                                                  << 8499>>53920000
     begin                                                     << 8499>>53925000
     move out'buff( ob'index ) := ";NOMULTI";                  << 8499>>53930000
     ob'index := ob'index + 8;                                 << 8499>>53935000
     end;                                                      << 8499>>53940000
                                                               << 8499>>53945000
     << 53 >>                                                  << 8499>>53950000
     begin                                                     << 8499>>53955000
     move out'buff( ob'index ) := ";WAIT";                     << 8499>>53960000
     ob'index := ob'index + 5;                                 << 8499>>53965000
     end;                                                      << 8499>>53970000
                                                               << 8499>>53975000
     << 54 >>                                                  << 8499>>53980000
     begin                                                     << 8499>>53985000
     move out'buff( ob'index ) := ";NOWAIT";                   << 8499>>53990000
     ob'index := ob'index + 7;                                 << 8499>>53995000
     end;                                                      << 8499>>54000000
                                                               << 8499>>54005000
     << 55 >>                                                  << 8499>>54010000
     begin                                                     << 8499>>54015000
     move out'buff( ob'index ) := ";GMULTI";                   << 8499>>54020000
     ob'index := ob'index + 7;                                 << 8499>>54025000
     end;                                                      << 8499>>54030000
                                                               << 8499>>54035000
     << 56 >>                                                  << 8499>>54040000
     begin                                                     << 8499>>54045000
     move out'buff( ob'index ) := ";STD";                      << 8499>>54050000
     ob'index := ob'index + 4;                                 << 8499>>54055000
     end;                                                      << 8499>>54060000
                                                               << 8499>>54065000
     << 57 >>                                                  << 8499>>54070000
     begin                                                     << 8499>>54075000
     move out'buff( ob'index ) := ";RIO";                      << 8499>>54080000
     ob'index := ob'index + 4;                                 << 8499>>54085000
     end;                                                      << 8499>>54090000
                                                               << 8499>>54095000
     << 58 >>                                                  << 8499>>54100000
     begin                                                     << 8499>>54105000
     move out'buff( ob'index ) := ";MSG";                      << 8499>>54110000
     ob'index := ob'index + 4;                                 << 8499>>54115000
     end;                                                      << 8499>>54120000
                                                               << 8499>>54125000
     << 59 >>                                                  << 8499>>54130000
     begin                                                     << 8499>>54135000
     move out'buff( ob'index ) := ";CIR";                      << 8499>>54140000
     ob'index := ob'index + 4;                                 << 8499>>54145000
     end;                                                      << 8499>>54150000
                                                               << 8499>>54155000
     << 60 >>                                                  << 8499>>54160000
     begin                                                     << 8499>>54165000
     move out'buff( ob'index ) := ";COPY";                     << 8499>>54170000
     ob'index := ob'index + 5;                                 << 8499>>54175000
     end;                                                      << 8499>>54180000
                                                               << 8499>>54185000
     << 61 >>                                                  << 8499>>54190000
     begin                                                     << 8499>>54195000
     move out'buff( ob'index ) := ";NOCOPY";                   << 8499>>54200000
     ob'index := ob'index + 7;                                 << 8499>>54205000
     end;                                                      << 8499>>54210000
                                                               << 8499>>54215000
                                                               << 8499>>54220000
                                                               << 8499>>54225000
     end; << case statement >>                                 << 8499>>54230000
                                                               << 8499>>54235000
end;   << load'string >>                                       << 8499>>54240000
$page                                                          << 8499>>54245000
<<**********************************************************>> << 8499>>54250000
<<                                                          >> << 8499>>54255000
<< subroutine putnum                                        >> << 8499>>54260000
<<                                                          >> << 8499>>54265000
<< purpose - to place a value into output buffer out'buff   >> << 8499>>54270000
<<                                                          >> << 8499>>54275000
<<**********************************************************>> << 8499>>54280000
                                                               << 8499>>54285000
subroutine putnum( val );                                      << 8499>>54290000
value val;                                                     << 8499>>54295000
integer val;                                                   << 8499>>54300000
<<***********************************************************>><< 8499>>54305000
<<                                                           >><< 8499>>54310000
<< val - an integer to by "ASCII"ed into a base 10 char str  >><< 8499>>54315000
<<                                                           >><< 8499>>54320000
<<***********************************************************>><< 8499>>54325000
begin                                                          << 8499>>54330000
tos:=ascii( val, 10, out'buff( ob'index ) );                   << 8499>>54335000
ob'index := ob'index + tos;                                    << 8499>>54340000
end;                                                           << 8499>>54345000
$page                                                          << 8499>>54350000
<<***********************************************************>><< 8499>>54355000
<<                                                           >><< 8499>>54360000
<< subroutine putdnum                                        >><< 8499>>54365000
<<                                                           >><< 8499>>54370000
<< purpose - to convert a value to a double base 10 and place>><< 8499>>54375000
<<           it in out'buff.                                 >><< 8499>>54380000
<<                                                           >><< 8499>>54385000
<<***********************************************************>><< 8499>>54390000
                                                               << 8499>>54395000
subroutine putdnum( val );                                     << 8499>>54400000
value val;                                                     << 8499>>54405000
double val;                                                    << 8499>>54410000
<<************************************************************><< 8499>>54415000
<<                                                            ><< 8499>>54420000
<< val - a double by value to be "ASCII"ed into out'buff      ><< 8499>>54425000
<<                                                            ><< 8499>>54430000
<<************************************************************><< 8499>>54435000
                                                               << 8499>>54440000
begin                                                          << 8499>>54445000
tos:=dascii( val , 10, out'buff( ob'index ) );                 << 8499>>54450000
ob'index := ob'index + tos;                                    << 8499>>54455000
end;                                                           << 8499>>54460000
$page                                                          << 8499>>54465000
<<***********************************************************>><< 8499>>54470000
<<                                                           >><< 8499>>54475000
<< subroutine obtain'formal'desig                            >><< 8499>>54480000
<<                                                           >><< 8499>>54485000
<< purpose:  to load the name of the formal designator into  >><< 8499>>54490000
<<           the byte string out'buff.                       >><< 8499>>54495000
<<                                                           >><< 8499>>54500000
<<***********************************************************>><< 8499>>54505000
                                                               << 8499>>54510000
logical subroutine obtain'formal'desig;                        << 8499>>54515000
                                                               << 8499>>54520000
begin                                                          << 8499>>54525000
obtain'formal'desig := true;  << assume success >>             << 8499>>54530000
                                                               << 8499>>54535000
<< ok, here's the deal.  when the feq formal designator >>     << 8499>>54540000
<< ss placed in the jdt, it is crunched.  the encoding  >>     << 8499>>54545000
<< is as follows:  the high-order bit of the first      >>     << 8499>>54550000
<< byte of each qualifier is turned on and the         >>      << 8499>>54555000
<< last part of the formal designator name is           >>     << 8499>>54560000
<< terminated by a blank.                               >>     << 8499>>54565000
<<                                                      >>     << 8499>>54570000
<< for example, if the formal designator is             >>     << 8499>>54575000
<< file.group.acct, the high-order bit in the first     >>     << 8499>>54580000
<< byte of each qualifier (file, group, and acct would  >>     << 8499>>54585000
<< be turned on.  so for "FILE", instead of %043111 =   >>     << 8499>>54590000
<< "FI", the first word is %143111.  and "ACCT" is      >>     << 8499>>54595000
<< terminated by a blank.                               >>     << 8499>>54600000
<<                                                      >>     << 8499>>54605000
<< note:  this will raise hell when we decide to support>>     << 8499>>54610000
<< 8-bit names!!!!!!    native language - watch out!!!  >>     << 8499>>54615000
                                                               << 8499>>54620000
<< get the formal file name size in bytes >>                   << 8499>>54625000
                                                               << 8499>>54630000
feq'fname'size := feq'entry.(8:8);  << # words >>              << 8499>>54635000
feq'fname'size := feq'fname'size * 2; << # bytes >>            << 8499>>54640000
@filename := (@feq'entry + 1) * 2;  << byte ptr to fname >>    << 8499>>54645000
i := 0;                                                        << 8499>>54650000
while ( i < feq'fname'size ) do                                << 8499>>54655000
   begin                                                       << 8499>>54660000
   if filename( i ) >= %200  << the high order bit on? >>      << 8499>>54665000
      then begin                                               << 8499>>54670000
           << yes. start desig. name >>                        << 8499>>54675000
           << clear high order bit   >>                        << 8499>>54680000
           filename( i ) := filename( i ) - %200;              << 8499>>54685000
                                                               << 8499>>54690000
           << if i=0 then we have the start of a file name >>  << 8499>>54695000
           << and we don't need a "." denoting a group or  >>  << 8499>>54700000
           << account                                      >>  << 8499>>54705000
                                                               << 8499>>54710000
           if i <> 0                                           << 8499>>54715000
              then begin                                       << 8499>>54720000
                   << need a separator >>                      << 8499>>54725000
                   out'buff( ob'index ) := ".";                << 8499>>54730000
                   ob'index := ob'index + 1;                   << 8499>>54735000
                   end;                                        << 8499>>54740000
           end;                                                << 8499>>54745000
                                                               << 8499>>54750000
   << move character into out'buff, and increment >>           << 8499>>54755000
   << the counters                                >>           << 8499>>54760000
   if filename( i ) <> " "                                     << 8499>>54765000
      then begin                                               << 8499>>54770000
           out'buff( ob'index ) := filename( i );              << 8499>>54775000
           ob'index := ob'index + 1;                           << 8499>>54780000
           end;                                                << 8499>>54785000
   << else the end of the formal file designator if it is odd ><< 8499>>54790000
   << if formal name is odd in length, a blank is appended.   ><< 8499>>54795000
   << and we do not want the blank.                           ><< 8499>>54800000
   i := i + 1;                                                 << 8499>>54805000
   end;  << while stmt >>                                      << 8499>>54810000
                                                               << 8499>>54815000
                                                               << 8499>>54820000
<< move feq'entry to next major part of feq entry >>           << 8499>>54825000
<< must convert feq'fname'size back to words      >>           << 8499>>54830000
                                                               << 8499>>54835000
feq'fname'size := feq'fname'size/2;                            << 8499>>54840000
                                                               << 8499>>54845000
if feq'fname'size = 1                                          << 8499>>54850000
   then @feq'entry := @feq'entry + 2                           << 8499>>54855000
   else @feq'entry := ( @feq'entry + (feq'fname'size) ) + 1;   << 8499>>54860000
                                                               << 8499>>54865000
end; << obtain'formal'desig >>                                 << 8499>>54870000
$page                                                          << 8499>>54875000
<<***********************************************************>><< 8499>>54880000
<<                                                           >><< 8499>>54885000
<< subroutine obtain'pmasks                                  >><< 8499>>54890000
<<                                                           >><< 8499>>54895000
<< purpose - to obtain the two paramter masks from the jdt   >><< 8499>>54900000
<<           that describe the feq.  one pair/feq.  loaded   >><< 8499>>54905000
<<           into parm1 and parm2.                           >><< 8499>>54910000
<<                                                           >><< 8499>>54915000
<<***********************************************************>><< 8499>>54920000
                                                               << 8499>>54925000
subroutine obtain'pmasks;                                      << 8499>>54930000
begin                                                          << 8499>>54935000
pmask1 := feq'entry;                                           << 8499>>54940000
@feq'entry := @feq'entry + 1;                                  << 8499>>54945000
pmask2 := feq'entry;                                           << 8499>>54950000
@feq'entry := @feq'entry + 1;                                  << 8499>>54955000
                                                               << 8499>>54960000
end;   << subroutine obtain'pmasks >>                          << 8499>>54965000
$page                                                          << 8499>>54970000
<<***********************************************************>><< 8499>>54975000
<<                                                           >><< 8499>>54980000
<< subroutine obtain'f'a'options                             >><< 8499>>54985000
<<                                                           >><< 8499>>54990000
<< purpose - to obtain the foptions and aoptions masks from  >><< 8499>>54995000
<<           the jdt.  one pair/feq.  describe the foptons   >><< 8499>>55000000
<<           and the aoptions of the feq.                    >><< 8499>>55005000
<<                                                           >><< 8499>>55010000
<<***********************************************************>><< 8499>>55015000
                                                               << 8499>>55020000
subroutine obtain'f'a'options;                                 << 8499>>55025000
begin                                                          << 8499>>55030000
                                                               << 8499>>55035000
<< feq'dname'size retreived in obtain'actual'fname >>          << 8499>>55040000
<< feq'entry is still pointing to the word containing lengths>><< 8499>>55045000
<< of actual and device strings.                             >><< 8499>>55050000
                                                               << 8499>>55055000
@temp'feq := @feq'entry;                                       << 8499>>55060000
@temp'feq := @temp'feq +                                       << 8499>>55065000
             ((feq'aname'size + feq'dname'size + 1)/2) + 1;    << 8499>>55070000
                                                               << 8499>>55075000
<< temp'feq now pointing to foptions word >>                   << 8499>>55080000
foptions := temp'feq;                                          << 8499>>55085000
aoptions := temp'feq( 1 );                                     << 8499>>55090000
end;   << subroutine obtain'f'a'options >>                     << 8499>>55095000
$page                                                          << 8499>>55100000
<<***********************************************************>><< 8499>>55105000
<<                                                           >><< 8499>>55110000
<< subroutine obtain'actual'fname                            >><< 8499>>55115000
<<                                                           >><< 8499>>55120000
<< purpose:  to load the actual file name into the output    >><< 8499>>55125000
<<           buffer out'buff if an actual file name exists.  >><< 8499>>55130000
<<           if the actual file name does not exist, then    >><< 8499>>55135000
<<           obtain'actual'fname returns false. else if an   >><< 8499>>55140000
<<           actual file name does exist, then return true   >><< 8499>>55145000
<<           only if a backreference is here, else return    >><< 8499>>55150000
<<           false.                                          >><< 8499>>55155000
<<                                                           >><< 8499>>55160000
<<***********************************************************>><< 8499>>55165000
                                                               << 8499>>55170000
logical subroutine obtain'actual'fname;                        << 8499>>55175000
begin                                                          << 8499>>55180000
<< @feq'entry is pointing to a word that contains the length >><< 8499>>55185000
<< in bytes of a possible actual file name designator in the >><< 8499>>55190000
<< first eight bits and the the length of a device class     >><< 8499>>55195000
<< name/number in the second half of the word.  we want to   >><< 8499>>55200000
<< get both of these values and move the actual name to the  >><< 8499>>55205000
<< output buffer (out'buff) if possible.                     >><< 8499>>55210000
                                                               << 8499>>55215000
<< when we exit, feq'entry needs to still be at the word     >><< 8499>>55220000
<< that contains the lengths.                                >><< 8499>>55225000
                                                               << 8499>>55230000
obtain'actual'fname := false; << assume actual fname w/o "*" >><< 8499>>55235000
                              << or not actual name at all   >><< 8499>>55240000
<< feq'aname'size is the number of characters, not including >><< 8499>>55245000
<< any packed blanks.                                        >><< 8499>>55250000
feq'aname'size := feq'entry.(0:8); << length in bytes >>       << 8499>>55255000
feq'dname'size := feq'entry.(8:8);  << length in bytes >>      << 8499>>55260000
if feq'aname'size <> 0                                         << 8499>>55265000
   then begin                                                  << 8499>>55270000
        << move the actual file name to the buffer >>          << 8499>>55275000
                                                               << 8499>>55280000
        load'string( equals );  << "=" >>                      << 8499>>55285000
        if feq'back'file'ref = 1                               << 8499>>55290000
           then begin                                          << 8499>>55295000
                                                               << 8499>>55300000
                << actual file is back referenced >>           << 8499>>55305000
                load'string( star ); << "*" >>                 << 8499>>55310000
                obtain'actual'fname := true;                   << 8499>>55315000
                end;                                           << 8499>>55320000
        @filename := ( @feq'entry + 1 ) * 2;                   << 8499>>55325000
        move out'buff( ob'index ) := filename,(feq'aname'size);<< 8499>>55330000
        ob'index := ob'index + feq'aname'size;                 << 8499>>55335000
        end;                                                   << 8499>>55340000
                                                               << 8499>>55345000
<< @feq'entry pointing to word conataining the lengths >>      << 8499>>55350000
                                                               << 8499>>55355000
end;   << subroutine obtain'actual'fname >>                    << 8499>>55360000
$page                                                          << 8499>>55365000
<<***********************************************************>><< 8499>>55370000
<<                                                           >><< 8499>>55375000
<< subroutine obtain'dev'info                                >><< 8499>>55380000
<<                                                           >><< 8499>>55385000
<< purpose:  to fill out'buff with all relevant information  >><< 8499>>55390000
<<           on the device number or device class name       >><< 8499>>55395000
<<                                                           >><< 8499>>55400000
<<***********************************************************>><< 8499>>55405000
                                                               << 8499>>55410000
subroutine obtain'dev'info;                                    << 8499>>55415000
begin                                                          << 8499>>55420000
                                                               << 8499>>55425000
<< @feq'entry is pointing to the device information in jdt   >><< 8499>>55430000
<< feq'dname'size was calculated inside obtain'actual fname  >><< 8499>>55435000
<< feq'dname'size is in bytes.                               >><< 8499>>55440000
                                                               << 8499>>55445000
<< fill an array full of cr's >>                               << 8499>>55450000
temp(0) := cr;                                                 << 8499>>55455000
move temp(1) := temp(0),(80);                                  << 8499>>55460000
                                                               << 8499>>55465000
<< now move the device information part into the array full >> << 8499>>55470000
<< of carriage returns.                                     >> << 8499>>55475000
                                                               << 8499>>55480000
<< if feq'aname'size <> 0, then @filename is still pointing >> << 8499>>55485000
<< to the beginnig of the actual filename string.  we will  >> << 8499>>55490000
<< use @filename to get to the start of the device string if>> << 8499>>55495000
<< that is the case.  else, calculate the start of the      >> << 8499>>55500000
<< device string from feq'entry (which is pointing to the   >> << 8499>>55505000
<< word containing the lengths of the actual filename and   >> << 8499>>55510000
<< device string).                                          >> << 8499>>55515000
                                                               << 8499>>55520000
if feq'aname'size <> 0                                         << 8499>>55525000
   then @devname := @filename( feq'aname'size )                << 8499>>55530000
   else @devname := (@feq'entry + 1) * 2;                      << 8499>>55535000
                                                               << 8499>>55540000
move temp := devname,( feq'dname'size );                       << 8499>>55545000
                                                               << 8499>>55550000
<< now separate the device part and its keyword (parameter) >> << 8499>>55555000
<< part.                                                    >> << 8499>>55560000
                                                               << 8499>>55565000
scan temp until %6473, 1; << look for cr, semicolon >>         << 8499>>55570000
devpart := tos - @temp;                                        << 8499>>55575000
keypart := feq'dname'size - devpart - 1;  << length kywds   >> << 8499>>55580000
                                                               << 8499>>55585000
<< move in the device information >>                           << 8499>>55590000
move out'buff( ob'index ) := devname,(devpart);                << 8499>>55595000
ob'index := ob'index + devpart;                                << 8499>>55600000
<< postion @feq'entry to the word after the aoptions word >>   << 8499>>55605000
                                                               << 8499>>55610000
<< now increment @feq'entry one past the aoptions word >>      << 8499>>55615000
                                                               << 8499>>55620000
@feq'entry := @feq'entry +                                     << 8499>>55625000
              ((feq'aname'size + feq'dname'size + 1)/2) + 3;   << 8499>>55630000
                                                               << 8499>>55635000
<< now see if any keywords exist for this device, if so put >> << 8499>>55640000
<< them into out'buff (outpri and numcopies)                >> << 8499>>55645000
                                                               << 8499>>55650000
if (( feq'num'copies = 1 ) lor ( feq'out'pri = 1 ))            << 8499>>55655000
   then begin                                                  << 8499>>55660000
        << numcopies or output priority kwds >>                << 8499>>55665000
        load'string( comma );                                  << 8499>>55670000
                                                               << 8499>>55675000
        << pick up the numcopies/outpri >>                     << 8499>>55680000
        i := integer( feq'entry( 6 ) );                        << 8499>>55685000
        if feq'out'pri = 1                                     << 8499>>55690000
           then putnum( i.(0:4) );                             << 8499>>55695000
        if feq'num'copies = 1                                  << 8499>>55700000
           then begin                                          << 8499>>55705000
                load'string( comma );                          << 8499>>55710000
                putnum( i.(4:7) );                             << 8499>>55715000
                end;                                           << 8499>>55720000
        end;                                                   << 8499>>55725000
                                                               << 8499>>55730000
<< get the key words suppied in jdt >>                         << 8499>>55735000
if keypart > 0                                                 << 8499>>55740000
   then begin                                                  << 8499>>55745000
        if ((devpart = 0) land (not (feq'num'copies) lor       << 8499>>55750000
                                    (feq'out'pri)))            << 8499>>55755000
           then ob'index := ob'index - 5;                      << 8499>>55760000
        @keywords := @devname + devpart; << start of kywds >>  << 8499>>55765000
        move out'buff( ob'index ) := keywords,(keypart);       << 8499>>55770000
        ob'index := ob'index + keypart;                        << 8499>>55775000
        end;                                                   << 8499>>55780000
                                                               << 8499>>55785000
                                                               << 8499>>55790000
end;   << subroutine obtain'dev'info >>                        << 8499>>55795000
$page                                                          << 8499>>55800000
<<************************************************************><< 8499>>55805000
<<                                                            ><< 8499>>55810000
<< subroutine obtain'forms'label'ksam                         ><< 8499>>55815000
<<                                                            ><< 8499>>55820000
<< purpose:  to load into out'buff information regarding any  ><< 8499>>55825000
<<           forms file, tape label, or ksam information      ><< 8499>>55830000
<<                                                            ><< 8499>>55835000
<<************************************************************><< 8499>>55840000
                                                               << 8499>>55845000
subroutine obtain'forms'label'ksam( type );                    << 8499>>55850000
value type;                                                    << 8499>>55855000
integer type;                                                  << 8499>>55860000
                                                               << 8499>>55865000
<<************************************************************><< 8499>>55870000
<<                                                            ><< 8499>>55875000
<< type - if 0 then load out'buff with tape label information ><< 8499>>55880000
<<      - if 1 then load out'buff with forms file information ><< 8499>>55885000
<<                                                            ><< 8499>>55890000
<<************************************************************><< 8499>>55895000
                                                               << 8499>>55900000
begin                                                          << 8499>>55905000
                                                               << 8499>>55910000
<< it is assumed that @feq'entry is pointing at the ref count ><< 8499>>55915000
<< and #user labels word in the feq                           ><< 8499>>55920000
                                                               << 8499>>55925000
label'length := feq'entry( 2 );                                << 8499>>55930000
if label'length <> 0                                           << 8499>>55935000
   then begin                                                  << 8499>>55940000
        case type of                                           << 8499>>55945000
             begin                                             << 8499>>55950000
                                                               << 8499>>55955000
             << 0 >> << forms >>                               << 8499>>55960000
             begin                                             << 8499>>55965000
             @form :=  @feq'entry( 3 ) * 2;                    << 8499>>55970000
             scan form until "..",1;                           << 8499>>55975000
             @eof := tos;                                      << 8499>>55980000
             if @eof > @form                                   << 8499>>55985000
                then begin                                     << 8499>>55990000
                     load'string( equals );                    << 8499>>55995000
                     i := @eof - @form + 1;                    << 8499>>56000000
                     move out'buff( ob'index ) := form,(i);    << 8499>>56005000
                     ob'index := ob'index + i;                 << 8499>>56010000
                     end;                                      << 8499>>56015000
             end;  << forms >>                                 << 8499>>56020000
                                                               << 8499>>56025000
             << 1 >> << label >>                               << 8499>>56030000
             begin                                             << 8499>>56035000
             @label'f := @feq'entry( 3 ) * 2;                  << 8499>>56040000
             scan label'f until "..",1;                        << 8499>>56045000
             @eof := tos;                                      << 8499>>56050000
             if label'length > (@eof - @label'f + 1 )          << 8499>>56055000
                then begin                                     << 8499>>56060000
                     load'string( equals );                    << 8499>>56065000
                     i := label'length -(@eof-@label'f) - 2;   << 8499>>56070000
                     move out'buff( ob'index ) := eof(1),(i);  << 8499>>56075000
                     ob'index := ob'index + i;                 << 8499>>56080000
                     end;                                      << 8499>>56085000
             end;   << label >>                                << 8499>>56090000
                                                               << 8499>>56095000
             end;   << case stmt >>                            << 8499>>56100000
                                                               << 8499>>56105000
        end;  << begin  - label'length <> 0 >>                 << 8499>>56110000
                                                               << 8499>>56115000
end;  << obtain'forms'label'ksam >>                            << 8499>>56120000
$page                                                          << 8499>>56125000
<<*************************************************************<< 8499>>56130000
<<                                                             << 8499>>56135000
<< subroutine format'with'pmasks                               << 8499>>56140000
<<                                                             << 8499>>56145000
<< purpose:  to format the feq into the output buffer out'buff << 8499>>56150000
<<           according to the various bit maps in pmask1 and   << 8499>>56155000
<<           pmask2.                                           << 8499>>56160000
<<                                                             << 8499>>56165000
<<*************************************************************<< 8499>>56170000
                                                               << 8499>>56175000
subroutine format'with'pmasks;                                 << 8499>>56180000
begin                                                          << 8499>>56185000
                                                               << 8499>>56190000
<< upon entrance to this subroutine, @feq'entry is pointing >> << 8499>>56195000
<< to either the start of the device class/device number    >> << 8499>>56200000
<< entries or at the word immediately following the word    >> << 8499>>56205000
<< containing the aoptions.                                 >> << 8499>>56210000
                                                               << 8499>>56215000
<< formal designator keywords >>                               << 8499>>56220000
if feq'default'desig = 1                                       << 8499>>56225000
   then case fopt'default'desig of                             << 8499>>56230000
             begin                                             << 8499>>56235000
             << 0 >> << file name >>                           << 8499>>56240000
             ;                                                 << 8499>>56245000
                                                               << 8499>>56250000
             << 1 >> << $stdlist  >>                           << 8499>>56255000
             load'string( stdlist );                           << 8499>>56260000
                                                               << 8499>>56265000
             << 2 >> << $newpass  >>                           << 8499>>56270000
             load'string( newpass );                           << 8499>>56275000
                                                               << 8499>>56280000
             << 3 >> << $oldpass  >>                           << 8499>>56285000
             load'string( oldpass );                           << 8499>>56290000
                                                               << 8499>>56295000
             << 4 >> << $stdin    >>                           << 8499>>56300000
             load'string( stdin   );                           << 8499>>56305000
                                                               << 8499>>56310000
             << 5 >> << $stdinx   >>                           << 8499>>56315000
             load'string( stdinx  );                           << 8499>>56320000
                                                               << 8499>>56325000
             << 6 >> << $null     >>                           << 8499>>56330000
             load'string(  null   );                           << 8499>>56335000
                                                               << 8499>>56340000
             end;  << case statement >>                        << 8499>>56345000
                                                               << 8499>>56350000
                                                               << 8499>>56355000
<< new/old/oldtemp/ keywords >>                                << 8499>>56360000
if feq'domain = 1                                              << 8499>>56365000
   then case fopt'domain of                                    << 8499>>56370000
             begin                                             << 8499>>56375000
                                                               << 8499>>56380000
             << 0 >> << new >>                                 << 8499>>56385000
             load'string( new );                               << 8499>>56390000
                                                               << 8499>>56395000
             << 1 >> << old >>                                 << 8499>>56400000
             load'string( old );                               << 8499>>56405000
                                                               << 8499>>56410000
             << 2 >> << oldtemp >>                             << 8499>>56415000
             load'string( oldtemp );                           << 8499>>56420000
                                                               << 8499>>56425000
             end; << case stmt >>                              << 8499>>56430000
                                                               << 8499>>56435000
<< feq'device is set if ;dev=, ;env=, or ;outq= >>             << 8499>>56440000
if ((feq'device = 1) lor (feq'num'copies=1)lor(feq'out'pri=1)  << 8499>>56445000
                     lor (feq'vterm = 1   ))                   << 8499>>56450000
   then begin                                                  << 8499>>56455000
        load'string( dev );                                    << 8499>>56460000
        obtain'dev'info;    << load the device name >>         << 8499>>56465000
                            << and any parameters   >>         << 8499>>56470000
        end << getting device information >>                   << 8499>>56475000
   else begin                                                  << 8499>>56480000
                                                               << 8499>>56485000
        << need to properly increment feq'entry >>             << 8499>>56490000
                                                               << 8499>>56495000
        @feq'entry := @feq'entry +                             << 8499>>56500000
                      ((feq'aname'size+feq'dname'size+1)/2)+3; << 8499>>56505000
        end;  << else begin >>                                 << 8499>>56510000
                                                               << 8499>>56515000
<< @feq'entry is now pointing to the numbuffer/init allocat >> << 8499>>56520000
<< word in feq.  this is the word immediately after the     >> << 8499>>56525000
<< aoptions word                                            >> << 8499>>56530000
                                                               << 8499>>56535000
<< rec keyword >>                                              << 8499>>56540000
if ((feq'block'factor=1) lor                                   << 8499>>56545000
    (feq'rec'size = 1  ) lor                                   << 8499>>56550000
    (feq'rec'fmt  = 1  ) lor                                   << 8499>>56555000
    (feq'ascii    = 1  ) )                                     << 8499>>56560000
   then begin                                                  << 8499>>56565000
        << rec = >>                                            << 8499>>56570000
        load'string( rec );                                    << 8499>>56575000
        if feq'rec'size = 1                                    << 8499>>56580000
           then putnum( feq'entry( 1 ) ); << record size >>    << 8499>>56585000
                                                               << 8499>>56590000
        if (( feq'block'factor = 1 ) lor                       << 8499>>56595000
            ( feq'rec'fmt      = 1 ) lor                       << 8499>>56600000
            ( feq'ascii        = 1 ) )                         << 8499>>56605000
           then begin                                          << 8499>>56610000
                load'string( comma );                          << 8499>>56615000
                if feq'block'factor = 1                        << 8499>>56620000
                   then putnum( feq'entry( 2 ).(8:8) );        << 8499>>56625000
                                                               << 8499>>56630000
                if (( feq'rec'fmt = 1 ) lor                    << 8499>>56635000
                    ( feq'ascii   = 1 ) )                      << 8499>>56640000
                   then begin                                  << 8499>>56645000
                        load'string( comma );                  << 8499>>56650000
                        if feq'rec'fmt = 1                     << 8499>>56655000
                           then case fopt'record'fmt of        << 8499>>56660000
                                     begin                     << 8499>>56665000
                                                               << 8499>>56670000
                                     << 0 >> << f >>           << 8499>>56675000
                                     load'string( fixed );     << 8499>>56680000
                                                               << 8499>>56685000
                                     << 1 >> << v >>           << 8499>>56690000
                                     load'string( variable' ); << 8499>>56695000
                                                               << 8499>>56700000
                                     << 2 >> << u >>           << 8499>>56705000
                                     load'string( undefined ); << 8499>>56710000
                                                               << 8499>>56715000
                                     end;<< case stmt >>       << 8499>>56720000
                                                               << 8499>>56725000
                        if feq'ascii = 1                       << 8499>>56730000
                           then begin                          << 8499>>56735000
                                case fopt'ascii'binary of      << 8499>>56740000
                                     begin                     << 8499>>56745000
                                                               << 8499>>56750000
                                     << 0 >> << binary >>      << 8499>>56755000
                                     load'string( binary' );   << 8499>>56760000
                                                               << 8499>>56765000
                                     << 1 >> << ascii >>       << 8499>>56770000
                                     load'string( ascii' );    << 8499>>56775000
                                                               << 8499>>56780000
                                     end; << case stmt >>      << 8499>>56785000
                                                               << 8499>>56790000
                                end; << feq'ascii = 1 >>       << 8499>>56795000
                                                               << 8499>>56800000
                        end; << feq'rec'fmt  or feq'ascii >>   << 8499>>56805000
                                                               << 8499>>56810000
                end;  << feq'block'factor or feq'rec'fmt >>    << 8499>>56815000
                      << or feq'ascii                    >>    << 8499>>56820000
                                                               << 8499>>56825000
        end; << feq'block'factor or feq'rec'size or >>         << 8499>>56830000
             << feq'rec'fmt or feq'ascii            >>         << 8499>>56835000
                                                               << 8499>>56840000
                                                               << 8499>>56845000
<< disc keyword >>                                             << 8499>>56850000
if (( feq'init'alloc  = 1 ) lor                                << 8499>>56855000
    ( feq'num'extents = 1 ) lor                                << 8499>>56860000
    ( feq'file'size   = 1 ) )                                  << 8499>>56865000
    then begin                                                 << 8499>>56870000
         load'string( disc );  << ;disc= >>                    << 8499>>56875000
         @file'size := @feq'entry+ 3;    << double file size >><< 8499>>56880000
         if feq'file'size = 1                                  << 8499>>56885000
            then putdnum( file'size ); << load file size >>    << 8499>>56890000
         if (( feq'num'extents = 1 ) lor                       << 8499>>56895000
             ( feq'init'alloc  = 1 ) )                         << 8499>>56900000
            then begin                                         << 8499>>56905000
                 load'string( comma );                         << 8499>>56910000
                 if feq'num'extents = 1                        << 8499>>56915000
                    then putnum( feq'entry( 2 ).(0:5) + 1 );   << 8499>>56920000
                                                               << 8499>>56925000
                 if feq'init'alloc = 1                         << 8499>>56930000
                    then begin                                 << 8499>>56935000
                         load'string( comma );                 << 8499>>56940000
                         putnum( feq'entry( 0 ).(8:5) + 1 );   << 8499>>56945000
                         end; << feq'init'allloc >>            << 8499>>56950000
                                                               << 8499>>56955000
                 end;  << feq'num'extents or feq'init'alloc >> << 8499>>56960000
                                                               << 8499>>56965000
         end; << feq'file'size or feq'num'extents >>           << 8499>>56970000
              << feq'init'alloc                   >>           << 8499>>56975000
                                                               << 8499>>56980000
if (( feq'buf'inhibit = 1 ) land ( aopt'nobuff = 1 ))          << 8499>>56985000
   then load'string( nobuf );                                  << 8499>>56990000
                                                               << 8499>>56995000
<< cctl/nocctl keywords >>                                     << 8499>>57000000
if feq'cctl = 1                                                << 8499>>57005000
   then if fopt'cctl = 1                                       << 8499>>57010000
           then load'string( cctl )                            << 8499>>57015000
           else load'string( nocctl );                         << 8499>>57020000
                                                               << 8499>>57025000
if feq'multi'rec = 1                                           << 8499>>57030000
   then if aopt'multi'record = 1                               << 8499>>57035000
           then load'string( mr )                              << 8499>>57040000
           else load'string( nomr );                           << 8499>>57045000
                                                               << 8499>>57050000
                                                               << 8499>>57055000
<< exc/ear/shr keywords >>                                     << 8499>>57060000
if feq'exclusive = 1                                           << 8499>>57065000
   then case aopt'exclusive'ac of                              << 8499>>57070000
             begin                                             << 8499>>57075000
                                                               << 8499>>57080000
             << 0 >> << default >>                             << 8499>>57085000
             ;                                                 << 8499>>57090000
             << 1 >> << exclusive >>                           << 8499>>57095000
             load'string( exc );                               << 8499>>57100000
                                                               << 8499>>57105000
             << 2 >> << semi >>                                << 8499>>57110000
             load'string( semi );                              << 8499>>57115000
                                                               << 8499>>57120000
             << 3 >> << shared >>                              << 8499>>57125000
             load'string( shr  );                              << 8499>>57130000
                                                               << 8499>>57135000
             end; << case stmt >>                              << 8499>>57140000
                                                               << 8499>>57145000
<< acc keyword >>                                              << 8499>>57150000
if feq'access'type = 1                                         << 8499>>57155000
   then begin                                                  << 8499>>57160000
        load'string( acc );                                    << 8499>>57165000
        case aopt'access'type of                               << 8499>>57170000
             begin                                             << 8499>>57175000
                                                               << 8499>>57180000
             << 0 >> << in - read only >>                      << 8499>>57185000
             load'string( in );                                << 8499>>57190000
                                                               << 8499>>57195000
             << 1 >> << out - write only >>                    << 8499>>57200000
             load'string( out );                               << 8499>>57205000
                                                               << 8499>>57210000
             << 2 >> << outkeep - write only(save) >>          << 8499>>57215000
             load'string( outkeep );                           << 8499>>57220000
                                                               << 8499>>57225000
             << 3 >> << append - append only >>                << 8499>>57230000
             load'string( append );                            << 8499>>57235000
                                                               << 8499>>57240000
             << 4 >> << inout - read/write >>                  << 8499>>57245000
             load'string( inout );                             << 8499>>57250000
                                                               << 8499>>57255000
             << 5 >> << update >>                              << 8499>>57260000
             load'string( update );                            << 8499>>57265000
                                                               << 8499>>57270000
             << 6 >> << execute - not used >>                  << 8499>>57275000
                                                               << 8499>>57280000
             end; << case stmt >>                              << 8499>>57285000
                                                               << 8499>>57290000
        end;  << feq'access'type = 1 >>                        << 8499>>57295000
                                                               << 8499>>57300000
<< buf keyword >>                                              << 8499>>57305000
if feq'num'buffs = 1                                           << 8499>>57310000
   then begin                                                  << 8499>>57315000
        load'string( buf ); << ;buff= >>                       << 8499>>57320000
        putnum( feq'entry( 0 ).(0:8) );                        << 8499>>57325000
        end;                                                   << 8499>>57330000
                                                               << 8499>>57335000
<< del/save/temp keywords >>                                   << 8499>>57340000
if feq'disp = 1                                                << 8499>>57345000
   then if feq'entry( 0 ).(13:1) = 1                           << 8499>>57350000
           then load'string( del' )                            << 8499>>57355000
           else if feq'entry( 0 ).(14:1) = 1                   << 8499>>57360000
                   then load'string( temp' )                   << 8499>>57365000
                   else if feq'entry( 0 ).(15:1) = 1           << 8499>>57370000
                           then load'string( save );           << 8499>>57375000
                                                               << 8499>>57380000
<< copy/nocopy keywords >>                                     << 8499>>57385000
if feq'copy = 1                                                << 8499>>57390000
   then case aopt'copy of                                      << 8499>>57395000
             begin                                             << 8499>>57400000
                                                               << 8499>>57405000
             << 0 >> << nocopy - native mode >>                << 8499>>57410000
             load'string( nocopy );                            << 8499>>57415000
                                                               << 8499>>57420000
             << 1 >> << copy - seq file access >>              << 8499>>57425000
             load'string( copy );                              << 8499>>57430000
                                                               << 8499>>57435000
             end;  << case stmt >>                             << 8499>>57440000
                                                               << 8499>>57445000
<< code keyword >>                                             << 8499>>57450000
if feq'file'code = 1                                           << 8499>>57455000
   then begin                                                  << 8499>>57460000
        load'string( code );  << ;code= >>                     << 8499>>57465000
        putnum( feq'entry( 5 ) ); << file code >>              << 8499>>57470000
        end;                                                   << 8499>>57475000
                                                               << 8499>>57480000
<< multi/nomulti/gmulti keywords >>                            << 8499>>57485000
if feq'multi'access = 1                                        << 8499>>57490000
   then case aopt'multi'access of                              << 8499>>57495000
             begin                                             << 8499>>57500000
                                                               << 8499>>57505000
             << 0 >> << nomulti - non-multiple access >>       << 8499>>57510000
             load'string( nomulti );                           << 8499>>57515000
                                                               << 8499>>57520000
             << 1 >> << multi - intra-job multiple access >>   << 8499>>57525000
             load'string( multi );                             << 8499>>57530000
                                                               << 8499>>57535000
             << 2 >> << gmulti - inter-job multiple access >>  << 8499>>57540000
             load'string( gmulti );                            << 8499>>57545000
                                                               << 8499>>57550000
             end; << case stmt >>                              << 8499>>57555000
                                                               << 8499>>57560000
<< wait/nowait keywords >>                                     << 8499>>57565000
if feq'wait = 1                                                << 8499>>57570000
   then if aopt'nowait = 1                                     << 8499>>57575000
           then load'string( nowait )                          << 8499>>57580000
           else load'string( wait   );                         << 8499>>57585000
                                                               << 8499>>57590000
<< increment @feq'entry to the start of the ref count and >>   << 8499>>57595000
<< number of user labels word                             >>   << 8499>>57600000
                                                               << 8499>>57605000
@feq'entry := @feq'entry + 7;                                  << 8499>>57610000
                                                               << 8499>>57615000
<< nolabel/label = keyword >>                                  << 8499>>57620000
if (( feq'labeled'tape = 1 ) land                              << 8499>>57625000
    ( fopt'tape'label'f = 0) )                                 << 8499>>57630000
    then load'string( nolabel )                                << 8499>>57635000
    else if feq'labeled'tape = 1                               << 8499>>57640000
             then begin                                        << 8499>>57645000
                  load'string( label' );                       << 8499>>57650000
                  obtain'forms'label'ksam( tape'label );       << 8499>>57655000
                 end;                                          << 8499>>57660000
                                                               << 8499>>57665000
if feq'file'type = 1                                           << 8499>>57670000
   then case fopt'file'type of                                 << 8499>>57675000
             begin                                             << 8499>>57680000
                                                               << 8499>>57685000
             << 0 >> << std file >>                            << 8499>>57690000
             load'string( std );                               << 8499>>57695000
                                                               << 8499>>57700000
             << 1 >> << ksam >>                                << 8499>>57705000
             load'string( ksam' );                             << 8499>>57710000
                                                               << 8499>>57715000
             << 2 >> << rio >>                                 << 8499>>57720000
             load'string( rio );                               << 8499>>57725000
                                                               << 8499>>57730000
             << 3 >> << undefined - not used >>                << 8499>>57735000
             ;                                                 << 8499>>57740000
                                                               << 8499>>57745000
             << 4 >> << cir >>                                 << 8499>>57750000
             load'string( cir );                               << 8499>>57755000
                                                               << 8499>>57760000
             << 5 >> << undefined - not used >>                << 8499>>57765000
             ;                                                 << 8499>>57770000
                                                               << 8499>>57775000
             << 6 >> << msg >>                                 << 8499>>57780000
             load'string( msg );                               << 8499>>57785000
                                                               << 8499>>57790000
             end; << case stmt >>                              << 8499>>57795000
                                                               << 8499>>57800000
<< form keyword >>                                             << 8499>>57805000
if feq'forms = 1                                               << 8499>>57810000
   then begin                                                  << 8499>>57815000
        load'string( forms );                                  << 8499>>57820000
        obtain'forms'label'ksam( forms'type );                 << 8499>>57825000
        end;                                                   << 8499>>57830000
                                                               << 8499>>57835000
<< lock/nolock keyword >>                                      << 8499>>57840000
if feq'dynamic'lock = 1                                        << 8499>>57845000
   then if aopt'locking = 1                                    << 8499>>57850000
           then load'string( lock )                            << 8499>>57855000
           else load'string( nolock );                         << 8499>>57860000
                                                               << 8499>>57865000
end;  << format'with'pmasks >>                                 << 8499>>57870000
                                                               << 8499>>57875000
                                                               << 8499>>57880000
$page                                                          << 8499>>57885000
<<***********************************************************>><< 8499>>57890000
<<                                                           >><< 8499>>57895000
<< subroutine print'line                                     >><< 8499>>57900000
<<                                                           >><< 8499>>57905000
<< purpose - to print the output buffer of out'buff to the   >><< 8499>>57910000
<<           listfile, if applicable, or to stdlist.         >><< 8499>>57915000
<<                                                           >><< 8499>>57920000
<<***********************************************************>><< 8499>>57925000
                                                               << 8499>>57930000
subroutine print'line;                                         << 8499>>57935000
begin                                                          << 8499>>57940000
fwrite( file'num, out'buff'l, -ob'index, 0 );                  << 8499>>57945000
if <>                                                          << 8499>>57950000
   then cierr( errnum := 555 );                                << 8499>>57955000
                                                               << 8499>>57960000
end;  << print'line >>                                         << 8499>>57965000
$page                                                          << 8499>>57970000
<<**********************************************************>> << 8499>>57975000
<<                                                          >> << 8499>>57980000
<< subroutine list'file'error                               >> << 8499>>57985000
<<                                                          >> << 8499>>57990000
<< purpose:  prints the listfile errors                     >> << 8499>>57995000
<<                                                          >> << 8499>>58000000
<<**********************************************************>> << 8499>>58005000
                                                               << 8499>>58010000
subroutine list'file'error;                                    << 8499>>58015000
begin                                                          << 8499>>58020000
ferror'( file'num, error'parm );                               << 8499>>58025000
errnum := listffserr;                                          << 8499>>58030000
tos := listffserr;                                             << 8499>>58035000
tos := @l'f'name;                                              << 8499>>58040000
cierr( *, *, %10000, error'parm );                             << 8499>>58045000
fclose( file'num, 0, 0 );                                      << 8499>>58050000
end;                                                           << 8499>>58055000
$page                                                          << 8499>>58060000
                                                               << 8499>>58065000
<<***********************************************************>><< 8499>>58070000
<<                                                           >><< 8499>>58075000
<< subroutine close'listfile                                 >><< 8499>>58080000
<<                                                           >><< 8499>>58085000
<< purpose:  to close the listfile fopened before the feq    >><< 8499>>58090000
<<           formatting.                                     >><< 8499>>58095000
<<                                                           >><< 8499>>58100000
<<***********************************************************>><< 8499>>58105000
                                                               << 8499>>58110000
subroutine close'listfile;                                     << 8499>>58115000
                                                               << 8499>>58120000
begin                                                          << 8499>>58125000
<< if complete = false purge the file, else save it >>         << 8499>>58130000
<< file'num <> 2 if output not to $stdlist          >>         << 8499>>58135000
if file'num <> 2                                               << 8499>>58140000
   then begin                                                  << 8499>>58145000
        fclose( file'num, 2, 0 );                              << 8499>>58150000
        if <>                                                  << 8499>>58155000
           then list'file'error;                               << 8499>>58160000
        end;                                                   << 8499>>58165000
end;                                                           << 8499>>58170000
$page                                                          << 8499>>58175000
<<*********************************************************>>  << 8499>>58180000
<<                                                         >>  << 8499>>58185000
<< subroutine handle'list'file                                 << 8499>>58190000
<<                                                         >>  << 8499>>58195000
<< purpose - to fopen the list file, if any.  if the fopen >>  << 8499>>58200000
<<           succeeds, the return true. if the fopen fails >>  << 8499>>58205000
<<           return false.  if no list file was specified  >>  << 8499>>58210000
<<           in the paramter list, return true             >>  << 8499>>58215000
<<                                                         >>  << 8499>>58220000
<<*********************************************************>>  << 8499>>58225000
                                                               << 8499>>58230000
logical subroutine handle'list'file;                           << 8499>>58235000
                                                               << 8499>>58240000
begin                                                          << 8499>>58245000
file'num := 2;  << default to $stdlist w/no fopen >>           << 8499>>58250000
handle'list'file := true;                                      << 8499>>58255000
if l'f'len <> 0                                                << 8499>>58260000
   then begin                                                  << 8499>>58265000
                                                               << 8499>>58270000
        << fopen the listfile >>                               << 8499>>58275000
        move l'f'name( l'f'len + 1 ) := 0;                     << 8499>>58280000
                                                               << 8499>>58285000
        << foptions = new ascii,    feq, cctl >>               << 8499>>58290000
        << aoptions = write only, exclusive   >>               << 8499>>58295000
                                                               << 8499>>58300000
        file'num := fopen( l'f'name, %2504, %101 );            << 8499>>58305000
        if <>                                                  << 8499>>58310000
           then begin                                          << 8499>>58315000
                list'file'error;                               << 8499>>58320000
                fclose( file'num, 0, 0 );                      << 8499>>58325000
                handle'list'file := false;                     << 8499>>58330000
                end;                                           << 8499>>58335000
        end;                                                   << 8499>>58340000
end;  << handle'list'file >>                                   << 8499>>58345000
$page                                                          << 8499>>58350000
<<************************************************************><< 8499>>58355000
<<                                                            ><< 8499>>58360000
<< subroutine format'feq                                      ><< 8499>>58365000
<<                                                            ><< 8499>>58370000
<< purpose - the drive the formatting of the feq's            ><< 8499>>58375000
<<                                                            ><< 8499>>58380000
<<************************************************************><< 8499>>58385000
                                                               << 8499>>58390000
subroutine format'feq;                                         << 8499>>58395000
begin                                                          << 8499>>58400000
<< set the head and tail pointers to feq table >>              << 8499>>58405000
<< these pointers are jdtarr relative          >>              << 8499>>58410000
ob'index := 0;  << index to out'buff >>                        << 8499>>58415000
@feq'head := jdtjtfeqptr;                                      << 8499>>58420000
@feq'tail := jdtjtleqptr;                                      << 8499>>58425000
if @feq'head = @feq'tail                                       << 8499>>58430000
   then begin                                                  << 8499>>58435000
        complete := false;                                     << 8499>>58440000
        cierr( errnum := leq'no'feqs );        << no feqs here << 8499>>58445000
        end                                                    << 8499>>58450000
   else begin                                                  << 8499>>58455000
        << feq'entry is now pointing at the first feq entry >> << 8499>>58460000
        << once start of q relative array jdtarr is added   >> << 8499>>58465000
        @feq'entry := @feq'head + @jdtarr;                     << 8499>>58470000
        @feq'tail := @feq'tail + @jdtarr;                      << 8499>>58475000
                                                               << 8499>>58480000
        << now loop on @feq'entry until @feq'entry equals >>   << 8499>>58485000
        << @feq'tail, at which point the feqs should have >>   << 8499>>58490000
        << all been formatted and printed.                >>   << 8499>>58495000
                                                               << 8499>>58500000
        out'buff( 0 ) := space;                                << 8499>>58505000
        move out'buff( 1 ) := out'buff( 0 ),(255);             << 8499>>58510000
                                                               << 8499>>58515000
        ob'index := 2;                                         << 8499>>58520000
        << post a blank line >>                                << 8499>>58525000
        print'line;                                            << 8499>>58530000
        genmsg( 2, leq'feqs );                                 << 8499>>58535000
                                                               << 8499>>58540000
        complete := false;                                     << 8499>>58545000
        while ( @feq'entry < @feq'tail ) do                    << 8499>>58550000
          begin                                                << 8499>>58555000
          ob'index := 0;                                       << 8499>>58560000
          @save'feq'entry := @feq'entry;                       << 8499>>58565000
          out'buff(0) := space;                                << 8499>>58570000
          move out'buff(1) := out'buff(0),(255);               << 8499>>58575000
          feq'words := feq'entry.(0:8);  << # words/feq entry ><< 8499>>58580000
          load'string( file' );  << ":FILE " >>                << 8499>>58585000
                                                               << 8499>>58590000
          << get formal file designator name >>                << 8499>>58595000
          obtain'formal'desig;                                 << 8499>>58600000
          complete := true;  << printed something >>           << 8499>>58605000
                                                               << 8499>>58610000
          << get paramter masks - pmask1 and pmask2 >>         << 8499>>58615000
          obtain'pmasks;                                       << 8499>>58620000
                                                               << 8499>>58625000
          << get the actual file name if applicable >>         << 8499>>58630000
          if obtain'actual'fname                               << 8499>>58635000
             then begin                                        << 8499>>58640000
                  << that's it - print it >>                   << 8499>>58645000
                  << back referenced actual file >>            << 8499>>58650000
                  print'line;                                  << 8499>>58655000
                  end                                          << 8499>>58660000
             else begin                                        << 8499>>58665000
                  << continue on >>                            << 8499>>58670000
                                                               << 8499>>58675000
                  << obtain the foptions and aoptions >>       << 8499>>58680000
                  obtain'f'a'options;                          << 8499>>58685000
                                                               << 8499>>58690000
                  << continue formatting the feq >>            << 8499>>58695000
                  format'with'pmasks;                          << 8499>>58700000
                                                               << 8499>>58705000
                  << now print the results >>                  << 8499>>58710000
                  print'line;                                  << 8499>>58715000
                  end;                                         << 8499>>58720000
                                                               << 8499>>58725000
          << increment @feq'entry >>                           << 8499>>58730000
          @feq'entry := @save'feq'entry +                      << 8499>>58735000
                        feq'words;                             << 8499>>58740000
          end;   << while begin >>                             << 8499>>58745000
                                                               << 8499>>58750000
        << post a line after the list of feq's >>              << 8499>>58755000
        out'buff( 0 ) := space;                                << 8499>>58760000
        move out'buff( 1 ) := out'buff,( 10 );                 << 8499>>58765000
        ob'index := 2;                                         << 8499>>58770000
        print'line;                                            << 8499>>58775000
        end;  << else begin formatting feqs >>                 << 8499>>58780000
end;                                                           << 8499>>58785000
$page                                                          << 8499>>58790000
<<****************** main *************************************<< 8499>>58795000
                                                               << 8499>>58800000
                                                               << 8499>>58805000
                                                               << 8499>>58810000
turnofftraps;                                                  << 8499>>58815000
@parmpoint:=@parmsp(0);                                        << 8499>>58820000
<<*************************************************************<< 8499>>58825000
<< parmpoint - is the byte pointer to the command's parameter  << 8499>>58830000
<<             list  (it was assigned to by parmsp)            << 8499>>58835000
<< realname  - byte array to contain the file equation formal  >>       58840000
<<             designator.  will return "@" if none supplied   >>       58845000
<< l'f'len   - integer for list file name length               << 8499>>58850000
<< l'f'name  - byte pointer for the list file if supplied      << 8499>>58855000
<<*************************************************************<< 8499>>58860000
<<                                                             << 8499>>58865000
<< the procedure parselisteq will parse the parameter list and << 8499>>58870000
<< return the formal file equation name if supplied and the    >>       58875000
<< name of the list file name if supplied.  will output any    << 8499>>58880000
<< errors that are found                                       << 8499>>58885000
<<                                                             << 8499>>58890000
<< note that we obtain the jir through out the formating.  to  << 8499>>58895000
<< do this will only hold up the cimain's process tree for a   << 8499>>58900000
<< minimal period of time.  we get this even though we get a   << 8499>>58905000
<< copy of the jdt and do not scan the jdt in place.  it is    << 8499>>58910000
<< gotten to coincide with set and reset.                      << 8499>>58915000
                                                               << 8499>>58920000
if not parselisteq( parmpoint, l'f'len, l'f'name )             << 8499>>58925000
   then                                                        << 8499>>58930000
        << screwed up.  errors caught in parselisteq >>        << 8499>>58935000
        return                                                 << 8499>>58940000
   else begin                                                  << 8499>>58945000
                                                               << 8499>>58950000
        if handle'list'file  << open $stdlist >>               << 8499>>58955000
           then begin                                          << 8499>>58960000
                jir := lockjir;                                << 8499>>58965000
                if movejdt( jdtarr )          << get jdt >>    << 8765>>58970000
                   then begin                                  << 8499>>58975000
                        unlockjir( jir );                      << 8499>>58980000
                        format'feq;  << drive formatting of feq<< 8499>>58985000
                        close'listfile; << close listfile >>   << 8499>>58990000
                        end                                    << 8499>>58995000
                   else unlockjir( jir );                      << 8499>>59000000
                                                               << 8499>>59005000
                end << handle'list'file >>                     << 8499>>59010000
           else                                                << 8499>>59015000
        end; << else begin >>                                  << 8499>>59020000
                                                               << 8499>>59025000
return;                                                        << 8499>>59030000
end;                                                           << 8499>>59035000
$page    "LISTFTEMP COMMAND EXECUTOR"                          << 8500>>59040000
$control segment=cifilem                                       << 8500>>59045000
procedure cxlistftemp executorhead;                            << 8500>>59050000
option privileged, uncallable;                                 << 8500>>59055000
begin                                                          << 8500>>59060000
$include inclflab                                              << 8500>>59065000
$include inclcap                                               << 8500>>59070000
                                                               << 8500>>59075000
$page    "LISTFTEMP COMMAND EXECUTOR"                          << 8500>>59080000
equate jdt'len        = jdt'max'len;                           << 8500>>59085000
define pageeject      = fwrite(fnum,datebuf,0,%61) #,          << 8500>>59090000
       log            = logical#,                              << 8500>>59095000
       file'open      = flabdbl( 16 ) <> 0d#;                  << 8500>>59100000
equate f'stdlist      = 1,                                     << 8500>>59105000
       new'file       = 0,                                     << 8500>>59110000
       temp'domain    = 2,                                     << 8500>>59115000
       current'domain = 0;                                     << 8500>>59120000
define mvtabx = pvinfo.(4:4)#;                                 << 8921>>59125000
                                                               << 8921>>59130000
double dl := commasemicr;                                      << 8500>>59135000
integer numparms;                                              << 8500>>59140000
double array parms(0:3) = q;                                   << 8500>>59145000
                                                               << 8500>>59150000
integer array recipparms(0:sysl'parmlen-1);                    << 8500>>59155000
integer array ppresult(*) = recipparms(sysl'pprinx);           << 8500>>59160000
byte array bpresult(*) = ppresult;                             << 8500>>59165000
                                                               << 8500>>59170000
byte array filename(0:23);                                     << 8500>>59175000
                                                               << 8502>>59180000
byte array t'f(0:25);                                          << 8502>>59185000
                                                               << 8500>>59190000
byte array for'file'name(0:25);                                << 8500>>59195000
                                                               << 8500>>59200000
byte array fmt'user(0:25);                                     << 8500>>59205000
                                                               << 8500>>59210000
logical array jdtarr( 0:jdt'len - 1 );                         << 8500>>59215000
logical array jitarr( 0:jit'entry'size - 1 );                  << 8500>>59220000
                                                               << 8500>>59225000
integer array flab(0:127);                                     << 8500>>59230000
byte array flab'b(*) = flab;                                   << 8500>>59235000
double array flabdbl(*) = flab;                                << 8500>>59240000
                                                               << 8500>>59245000
double  array dextent'map(0:31);                               << 8500>>59250000
logical array extent'map(*) = dextent'map;                     << 8500>>59255000
                                                               << 8500>>59260000
double array extents(*) = flextmap;                            << 8500>>59265000
                                                               << 8500>>59270000
byte array user(0:7),                                          << 8500>>59275000
           account(0:7),                                       << 8500>>59280000
           lggroup(0:7);                                       << 8500>>59285000
                                                               << 8500>>59290000
logical array b'line(0:1);                                     << 8500>>59295000
                                                               << 8500>>59300000
logical array first'line(0:7);                                 << 8500>>59305000
byte array first'line'b(*) = first'line;                       << 8500>>59310000
                                                               << 8500>>59315000
byte array heading(0:45);                                      << 8500>>59320000
logical array heading'l(*) = heading;                          << 8500>>59325000
                                                               << 8500>>59330000
byte pointer leafname  = parms;                                << 8500>>59335000
integer leafnamechar   = parms+1;                              << 8500>>59340000
byte leafnamelen       = parms+1;                              << 8500>>59345000
byte pointer listlevel = parms+2;                              << 8500>>59350000
byte listlevellen      = parms+3;                              << 8500>>59355000
byte pointer listfile  = parms+2;  <<tricky bit>>              << 8500>>59360000
integer listfilechar   = parms+3;                              << 8500>>59365000
byte pointer extraparm = parms+6;                              << 8500>>59370000
byte extraparmlen      = parms+7;                              << 8500>>59375000
                                                               << 8500>>59380000
integer array out'buff( 0:37 );                                << 8500>>59385000
integer array ascii'part(*) = out'buff( 28 );                  << 8500>>59390000
                                                               << 8500>>59395000
byte array out'buff'b(*)   = out'buff;                         << 8500>>59400000
byte array ascii'part'b(*) = ascii'part;                       << 8500>>59405000
                                                               << 8500>>59410000
byte array priv'mnemonic(0:4),                                 << 8500>>59415000
           ksam(0:4);                                          << 8500>>59420000
                                                               << 8500>>59425000
logical pointer tfeq'entry,                                    << 8500>>59430000
                save'tfeq'entry,                               << 8500>>59435000
                tfeq'head,                                     << 8500>>59440000
                tfeq'tail;                                     << 8500>>59445000
                                                               << 8500>>59450000
equate comma = 0,                                              << 8500>>59455000
       semi  = 1,                                              << 8500>>59460000
        pv = 1,                                                << 8921>>59465000
       cr    = 2;                                              << 8500>>59470000
                                                               << 8500>>59475000
byte pointer delim;                                            << 8500>>59480000
                                                               << 8500>>59485000
byte array t'account(0:7);     << account in jdt entry >>      << 8500>>59490000
byte array d'account(0:7);     << account desired      >>      << 8500>>59495000
byte array w'account(0:7);    << holds logon account >>        << 8502>>59500000
                                                               << 8500>>59505000
byte array t'group(0:7);       << group in jdt entry   >>      << 8500>>59510000
byte array d'group(0:7);       << group desired        >>      << 8500>>59515000
byte array w'group(0:7);      << holds logon group   >>        << 8502>>59520000
                                                               << 8500>>59525000
byte array t'filename(0:7);    << filename in jdt entry>>      << 8500>>59530000
byte array d'filename(0:7);    << filename desired     >>      << 8500>>59535000
                                                               << 8921>>59540000
logical array t'account'l(*)   = t'account;                    << 8921>>59545000
logical array t'group'l(*)     = t'group;                      << 8921>>59550000
logical array t'filename'l(*)  = t'filename;                   << 8921>>59555000
                                                               << 8921>>59560000
                                                               << 8500>>59565000
integer sopen'foptions  := %2504,                              << 8500>>59570000
        num'extents'used:= 0,                                  << 8500>>59575000
        ob'index        := 0,                                  << 8500>>59580000
        fclose'options  := 2,   << temporary domain >>         << 8500>>59585000
        foptions        := 0,                                  << 8500>>59590000
        t'filenumber    := 0,                                  << 8500>>59595000
        l               := 0,                                  << 8500>>59600000
        volume'index    := 0,                                  << 8500>>59605000
        rsize           := 0,                                  << 8500>>59610000
        count           := 0,                                  << 8500>>59615000
        len             := 0,                                  << 8500>>59620000
        list'level      := 0,                                  << 8500>>59625000
        tfeq'entry'size := 0,                                  << 8500>>59630000
        tfeq'fname'size := 0,                                  << 8500>>59635000
        i               := 0,                                  << 8500>>59640000
        j               := 0,                                  << 8500>>59645000
        m               := 0,                                  << 8500>>59650000
        fl'mnemonic'len := 0,                                  << 8500>>59655000
        ldev            := 0,                                  << 8921>>59660000
        star            := [8/"*", 8/" "],                     << 8921>>59665000
        mount'req       := 2,                                  << 8921>>59670000
        success'mount   := false,                              << 8921>>59675000
        two             := 2,                                  << 8921>>59680000
        dev             := 0,  <<device type of list file>>    << 8500>>59685000
        pcbglobloc      := 0,  << for indexing user's stack >> << 8500>>59690000
        fnum            := 2;  <<default to $stdlist>>         << 8500>>59695000
                                                               << 8500>>59700000
logical stdlist     := true,                                   << 8500>>59705000
        max'exts    := 0,                                      << 8500>>59710000
        tfeq'words  := 0,                                      << 8500>>59715000
        jit'dst     := 0,                                      << 8500>>59720000
        jir         := 0,                                      << 8500>>59725000
        reprocess   := false,                                  << 8502>>59730000
        check'needed:= true,                                   << 8502>>59735000
        rec'size    := 0,                                      << 8500>>59740000
        already'prt := false,                                  << 8500>>59745000
        interactive := true;                                   << 8500>>59750000
                                                               << 8500>>59755000
double sector;  << sector address of file label >>             << 8500>>59760000
                                                               << 8921>>59765000
double direc'error;                                            << 8921>>59770000
double direc'index;                                            << 8921>>59775000
                                                               << 8921>>59780000
integer pvinfo;                                                << 8921>>59785000
                                                               << 8921>>59790000
logical array group'entry'array( 0 : gsize - 1 );              << 8921>>59795000
                                                               << 8921>>59800000
logical array file'info( 0:3 );                                << 8921>>59805000
                                                               << 8921>>59810000
                                                               << 8500>>59815000
                                                               << 8500>>59820000
logical sector0 = sector,                                      << 8500>>59825000
        sector1 = sector + 1;                                  << 8500>>59830000
                                                               << 8500>>59835000
                                                               << 8500>>59840000
array datebuf(0:13);  <<used for time stamp of output>>        << 8500>>59845000
array qarray(*)=q+0;                                           << 8500>>59850000
                                                               << 8500>>59855000
pointer ucapptr;                                               << 8500>>59860000
                                                               << 8500>>59865000
logical array head1(0:19);                                     << 8500>>59870000
                                                               << 8500>>59875000
logical array head2(0:25);                                     << 8500>>59880000
                                                               << 8500>>59885000
logical array head22(0:8);                                     << 8500>>59890000
                                                               << 8500>>59895000
logical array head3(0:16);                                     << 8500>>59900000
                                                               << 8500>>59905000
logical array head32(0:8);                                     << 8500>>59910000
                                                               << 8500>>59915000
byte array b'head1(*)  = head1;                                << 8500>>59920000
byte array b'head2(*)  = head2;                                << 8500>>59925000
byte array b'head22(*) = head22;                               << 8500>>59930000
byte array b'head3(*)  = head3;                                << 8500>>59935000
byte array b'head32(*) = head32;                               << 8500>>59940000
                                                               << 8500>>59945000
$page                                                          << 8500>>59950000
<<*************************************************************<< 8500>>59955000
<<                                                             << 8500>>59960000
<< subroutine init'buff                                        << 8500>>59965000
<<                                                             << 8500>>59970000
<< purpose:  to initialize out'buff to 80 blanks.              << 8500>>59975000
<<                                                             << 8500>>59980000
<<*************************************************************<< 8500>>59985000
                                                               << 8500>>59990000
subroutine init'buff;                                          << 8500>>59995000
begin                                                          << 8500>>60000000
ob'index := 0;                                                 << 8500>>60005000
i := 0;                                                        << 8500>>60010000
while( i < 76 ) do                                             << 8500>>60015000
     begin                                                     << 8500>>60020000
     out'buff'b( i ) := " ";                                   << 8500>>60025000
     i := i + 1                                                << 8500>>60030000
     end;                                                      << 8500>>60035000
end;                                                           << 8500>>60040000
$page                                                          << 8500>>60045000
<<************************************************************><< 8500>>60050000
<<                                                            ><< 8500>>60055000
<< subroutine format'user                                     ><< 8500>>60060000
<<                                                            ><< 8500>>60065000
<< purpose:  to format user.account,group                     ><< 8500>>60070000
<<           into heading.                                    ><< 8500>>60075000
<<                                                            ><< 8500>>60080000
<<************************************************************><< 8500>>60085000
subroutine format'user;                                        << 8500>>60090000
begin                                                          << 8500>>60095000
init'buff;                                                     << 8500>>60100000
who( , , ,user, lggroup, account );                                     60105000
move heading :=                                                << 8500>>60110000
         "TEMPORARY FILES FOR                           ";     << 8500>>60115000
l := 0;                                                        << 8500>>60120000
move fmt'user( 0 ) := user,(8);                                << 8500>>60125000
fmt'user( l + 8 ) := ".";                                      << 8500>>60130000
l := l + 9;                                                    << 8500>>60135000
move fmt'user( l ) := account,(8);                             << 8500>>60140000
fmt'user( l + 8 ) := ",";                                      << 8500>>60145000
l := l + 9;                                                    << 8500>>60150000
move fmt'user( l ) := lggroup,(8);                             << 8500>>60155000
                                                               << 8500>>60160000
<< remove the blanks and stuff >>                              << 8500>>60165000
l := 0;                                                        << 8500>>60170000
i := 20;                                                       << 8500>>60175000
while l <= 25 do                                               << 8500>>60180000
   begin                                                       << 8500>>60185000
   if fmt'user( l ) <> " "                                     << 8500>>60190000
      then begin                                               << 8500>>60195000
           move heading( i ) := fmt'user( l ),( 1 );           << 8500>>60200000
           i := i + 1;                                         << 8500>>60205000
           end;                                                << 8500>>60210000
   l := l + 1;                                                 << 8500>>60215000
   end;                                                        << 8500>>60220000
                                                               << 8500>>60225000
end;  << subroutine format'user >>                             << 8500>>60230000
$page                                                          << 8500>>60235000
<<************************************************************><< 8500>>60240000
<<                                                            ><< 8500>>60245000
<< subroutine format'file'name                                ><< 8500>>60250000
<<                                                            ><< 8500>>60255000
<< purpose:  to format f = file.group.account                 ><< 8500>>60260000
<<           into title for listftemp ,-1                     ><< 8500>>60265000
<<           using for'file'name and tfeq'fname'size from the ><< 8500>>60270000
<<           subroutine get'tfname.                           ><< 8500>>60275000
<<                                                            ><< 8500>>60280000
<<************************************************************><< 8500>>60285000
subroutine format'file'name;                                   << 8500>>60290000
begin                                                          << 8500>>60295000
init'buff;     << post another blank line >>                   << 8500>>60300000
fwrite( fnum, out'buff, 38, 0 );                               << 8500>>60305000
                                                               << 8500>>60310000
move out'buff'b( 0 ) := "F  =  ";                              << 8500>>60315000
move out'buff'b( 6 ) := for'file'name,( 26 );                  << 8500>>60320000
move out'buff'b( 7 + 26 + 3 ) :=                               << 8500>>60325000
               "(TEMPORARY FILE )";                            << 8500>>60330000
                                                               << 8500>>60335000
fwrite( fnum, out'buff, 38, 0 );                               << 8500>>60340000
end;  << subroutine format'file'name >>                        << 8500>>60345000
$page                                                          << 8500>>60350000
<<**********************************************************>> << 8500>>60355000
<<                                                          >> << 8500>>60360000
<< subroutine check'user'caps                               >> << 8500>>60365000
<<                                                             << 8500>>60370000
<< purpose:  to determine if the user is either an account  >> << 8500>>60375000
<<           or system manager.  if not check'user'caps     >> << 8500>>60380000
<<           returns false, else it returns true.           >> << 8500>>60385000
<<                                                          >> << 8500>>60390000
<<**********************************************************>> << 8500>>60395000
                                                               << 8500>>60400000
logical subroutine check'user'caps;                            << 8500>>60405000
begin                                                          << 8500>>60410000
pxglobal;                                                      << 8500>>60415000
@ucapptr := @pxg'userattributes;                               << 8500>>60420000
if ucapsm = 1 lor ucapam = 1                                   << 8921>>60425000
   then check'user'caps := true                                << 8500>>60430000
   else check'user'caps := false;                              << 8500>>60435000
end;                                                           << 8500>>60440000
$page                                                          << 8500>>60445000
<<***********************************************************>><< 8500>>60450000
<<                                                           >><< 8500>>60455000
<< subroutine list'level'ok                                  >><< 8500>>60460000
<<                                                           >><< 8500>>60465000
<< purpose: to retrieve the list level integer, or if none   >><< 8500>>60470000
<<          is supplied, set one.  the list level will be    >><< 8500>>60475000
<<          placed in the global list'level.  if any errors  >><< 8500>>60480000
<<          occur, list'level'ok will return false, else it  >><< 8500>>60485000
<<          will return true.                                >><< 8500>>60490000
<<                                                           >><< 8500>>60495000
<<***********************************************************>><< 8500>>60500000
                                                               << 8500>>60505000
logical subroutine list'level'ok;                              << 8500>>60510000
begin                                                          << 8500>>60515000
                                                               << 8500>>60520000
<< check for the listlevel, if any was supplied   >>           << 8500>>60525000
<< legal values are -1, 0, 1, or 2.  if any other >>           << 8500>>60530000
<< was supplied, a default of 2 is used as long   >>           << 8500>>60535000
<< as what was supplied is not less than -1, else >>           << 8500>>60540000
<< a -1 is used as long as the user has sm caps   >>           << 8500>>60545000
<< or am caps.  if no listlevel was supplied, the >>           << 8500>>60550000
<< default will be 0.                             >>           << 8500>>60555000
                                                               << 8500>>60560000
list'level'ok := true;  << assume success >>                   << 8500>>60565000
if leafnamechar.(11:5) = comma       <<listlevel present>>     << 8500>>60570000
   then begin                                                  << 8500>>60575000
        list'level :=binary( listlevel, integer(listlevellen));<< 8500>>60580000
        if <> or not(-1 <= list'level <= 2)                    << 8500>>60585000
          then begin   << bad conversion or bad number >>      << 8500>>60590000
               cierr( errnum := -listftempbadlevel,            << 8500>>60595000
                                listlevel );                   << 8500>>60600000
               if list'level < -1         <<give listf ,-1 >>  << 8500>>60605000
                  then list'level := -1                        << 8500>>60610000
                  else list'level := 2;  << give listf ,2 >>   << 8500>>60615000
                                                               << 8500>>60620000
               end;                                            << 8500>>60625000
                                                               << 8500>>60630000
        if list'level < 0    << check caps. if list'level = -1 << 8500>>60635000
           then if check'user'caps <> true                     << 8500>>60640000
                   then begin                                  << 8500>>60645000
                        cierr( errnum := listftempsmoram );    << 8500>>60650000
                        list'level'ok := false;                << 8500>>60655000
                        end;                                   << 8500>>60660000
        parms := parms(1);     << move up since list'file   >> << 8500>>60665000
        parms(1) := parms(2);  << is there if no listlevel  >> << 8500>>60670000
        end                                                    << 8500>>60675000
   else list'level := 0;  << list level default >>             << 8500>>60680000
                                                               << 8500>>60685000
end;  << subroutine list'level'ok >>                           << 8500>>60690000
$page                                                          << 8500>>60695000
<<************************************************************><< 8500>>60700000
<<                                                            ><< 8500>>60705000
<< subroutine list'file'ok                                    ><< 8500>>60710000
<<                                                            ><< 8500>>60715000
<< purpose:  to retieve any listfile from the command image   ><< 8500>>60720000
<<           and to fopen the file and return the file number ><< 8500>>60725000
<<           through the global variable fnum.  if any errors ><< 8500>>60730000
<<           occur, list'file'ok will return false, else it   ><< 8500>>60735000
<<           return true.                                     ><< 8500>>60740000
<<                                                            ><< 8500>>60745000
<<************************************************************><< 8500>>60750000
                                                               << 8500>>60755000
logical subroutine list'file'ok;                               << 8500>>60760000
begin                                                          << 8500>>60765000
                                                               << 8500>>60770000
list'file'ok := true;  << assume success >>                    << 8500>>60775000
if leafnamechar.(11:5) = semi  << listfile probably supplied >><< 8500>>60780000
   then if cibadfilename( errnum,parms(1) )                    << 8500>>60785000
           then list'file'ok := false                          << 8500>>60790000
           else stdlist := false   <<user specified a file >>  << 8500>>60795000
   else if leafnamechar.(11:5) = comma       <<error>>         << 8500>>60800000
           then begin                                          << 8500>>60805000
                cierr( errnum := listftempexpectfile,          << 8500>>60810000
                                 listfile );                   << 8500>>60815000
                list'file'ok := false;                         << 8500>>60820000
                end;                                           << 8500>>60825000
                                                               << 8500>>60830000
<< now check for extraneous parmeters >>                       << 8500>>60835000
if (listfilechar.(11:5) <> cr) and (extraparmlen<>0)           << 8500>>60840000
   then begin                                                  << 8500>>60845000
        cierr( errnum := listftemp2mp,extraparm );             << 8500>>60850000
        list'file'ok := false;                                 << 8500>>60855000
        end                                                    << 8500>>60860000
                                                               << 8500>>60865000
   else if not stdlist <<open user defined file>>              << 8500>>60870000
           then begin                                          << 8500>>60875000
                fnum := fopen(listfile, sopen'foptions, %101); << 8500>>60880000
                if <>                                          << 8500>>60885000
                   then begin                                  << 8500>>60890000
                        ferror'(fnum, parmnum);                << 8500>>60895000
                        cierr(errnum := listffserr,listfile,   << 8500>>60900000
                                        %10000,parmnum);       << 8500>>60905000
                        list'file'ok := false;                 << 8500>>60910000
                        end;                                   << 8500>>60915000
                end;                                           << 8500>>60920000
                                                               << 8500>>60925000
end;  << subroutine list'file'ok >>                            << 8500>>60930000
$page                                                          << 8502>>60935000
<<***********************************************************>><< 8502>>60940000
<<                                                           >><< 8502>>60945000
<< subroutine mod'for'file'name                              >><< 8502>>60950000
<<                                                           >><< 8502>>60955000
<< purpose:   to add "$OLDPASS" to for'file'name since we    >><< 8502>>60960000
<<            will have to reprocess the original formal file>><< 8502>>60965000
<<            name later.  we are actually updating the file >><< 8502>>60970000
<<            name and shifting the group and account around >><< 8502>>60975000
<<                                                           >><< 8502>>60980000
<<***********************************************************>><< 8502>>60985000
subroutine mod'for'file'name;                                  << 8502>>60990000
begin                                                          << 8502>>60995000
                                                               << 8502>>61000000
move t'f := "                          ";                      << 8502>>61005000
                                                               << 8502>>61010000
move t'f := "$OLDPASS";                                        << 8502>>61015000
i := 0;                                                        << 8502>>61020000
m := 8;                                                        << 8502>>61025000
                                                               << 8502>>61030000
<< find the start of the group name (including delimiter) >>   << 8502>>61035000
while ( for'file'name( i ) <> "." ) do                         << 8502>>61040000
   i := i + 1;                                                 << 8502>>61045000
                                                               << 8502>>61050000
<< move the group and account to t'f >>                        << 8502>>61055000
while i < 26 do                                                << 8502>>61060000
   begin                                                       << 8502>>61065000
   t'f( m ) := for'file'name( i );                             << 8502>>61070000
   i := i + 1;                                                 << 8502>>61075000
   m := m + 1;                                                 << 8502>>61080000
   end;                                                        << 8502>>61085000
                                                               << 8502>>61090000
<< now move t'f to for'file'name >>                            << 8502>>61095000
                                                               << 8502>>61100000
move for'file'name := "                          ";            << 8502>>61105000
move for'file'name := t'f,(26);                                << 8502>>61110000
                                                               << 8502>>61115000
end;       << subroutine mod'for'file'name >>                  << 8502>>61120000
$page                                                          << 8500>>61125000
<<**********************************************************>> << 8502>>61130000
<<                                                          >> << 8502>>61135000
<< subroutine handle'oldpass                                >> << 8502>>61140000
<<                                                          >> << 8502>>61145000
<< purpose:  1.  to obtain the user's jit dst number.       >> << 8502>>61150000
<<           2.  to use the jit dst number to get the       >> << 8502>>61155000
<<               passed file pointer - the sector           >> << 8502>>61160000
<<               information needed to get the information  >> << 8502>>61165000
<<               to display.                                >> << 8502>>61170000
<<           3.  return true if sector address <> 0d, else  >> << 8502>>61175000
<<               return false.                              >> << 8502>>61180000
<<                                                          >> << 8502>>61185000
<<**********************************************************>> << 8502>>61190000
                                                               << 8502>>61195000
logical subroutine handle'oldpass;                             << 8502>>61200000
                                                               << 8502>>61205000
begin                                                          << 8502>>61210000
                                                               << 8502>>61215000
          << get the jit dst number and the jit >>             << 8502>>61220000
          pxglobal;                                            << 8502>>61225000
          jit'dst := pxg'jitdst;                               << 8502>>61230000
                                                               << 8502>>61235000
          tos := @jitarr;                                      << 8502>>61240000
          tos := jit'dst;                                      << 8502>>61245000
          tos := 0;                                            << 8502>>61250000
          tos := jit'entry'size;                               << 8502>>61255000
          assemble( mfds 4 );                                  << 8502>>61260000
                                                               << 8502>>61265000
          << get the sector information >>                     << 8502>>61270000
          volume'index := jitpassfilevtabx;                    << 8502>>61275000
          sector0 := jitpassfileptr1;                          << 8502>>61280000
          sector1 := jitpassfileptr2;                          << 8502>>61285000
                                                               << 8502>>61290000
          if sector <> 0d                                      << 8502>>61295000
             then begin                                        << 8502>>61300000
                  << $oldpass is active - display info. >>     << 8502>>61305000
                  move t'filename := "$OLDPASS";               << 8502>>61310000
                  handle'oldpass := true;                      << 8502>>61315000
                  mod'for'file'name;  << move in $oldpass >>   << 8502>>61320000
                                                               << 8502>>61325000
                  end   << have a current $oldpass >>          << 8502>>61330000
                                                               << 8502>>61335000
             else handle'oldpass := false;  << no $oldpass >>  << 8502>>61340000
                                                               << 8502>>61345000
end;  << subroutine handle'oldpass >>                          << 8502>>61350000
$page                                                          << 8502>>61355000
<<***********************************************************>><< 8500>>61360000
<<                                                           >><< 8500>>61365000
<< subroutine get'tfname                                     >><< 8500>>61370000
<<                                                           >><< 8500>>61375000
<< purpose:  to determine if there is a match between the    >><< 8500>>61380000
<<           file name in the tfeq'entry and the desired     >><< 8500>>61385000
<<           name in ppresult.                               >><< 8500>>61390000
<<           the volume index and the sector address is      >><< 8500>>61395000
<<           placed in vol'index, and sector'addr, while the >><< 8500>>61400000
<<           file's name is put into t'account, t'group and  >><< 8500>>61405000
<<           t'filename;  only if there is a match.  if a    >><< 8500>>61410000
<<           match is realized, get'fname returns true, else >><< 8500>>61415000
<<           it returns false.                               >><< 8500>>61420000
<<                                                           >><< 8500>>61425000
<<***********************************************************>><< 8500>>61430000
                                                               << 8500>>61435000
logical subroutine get'tfname;                                 << 8500>>61440000
begin                                                          << 8500>>61445000
                                                               << 8500>>61450000
get'tfname := true;  << assume success >>                      << 8500>>61455000
tfeq'fname'size := tfeq'entry.(8:8);  << name size in words >> << 8500>>61460000
                                                               << 8500>>61465000
<< get filename byte array to start of filename.  each     >>  << 8500>>61470000
<< is fully qualified with high order bit in each byte of  >>  << 8500>>61475000
<< representing the character of each qualifier.  place the>>  << 8500>>61480000
<< the three qualifiers into each of the three t'xxxx vars.>>  << 8500>>61485000
move                                                           << 8500>>61490000
for'file'name := "                          ";                 << 8500>>61495000
                                                               << 8500>>61500000
tfeq'fname'size := tfeq'fname'size * 2; << # bytes long >>     << 8500>>61505000
@filename := (@tfeq'entry + 1) * 2;  << byte ptr to f name >>  << 8500>>61510000
move t'filename := "        ";                                 << 8500>>61515000
move t'group    := "        ";                                 << 8500>>61520000
move t'account  := "        ";                                 << 8500>>61525000
l := 0;                                                        << 8500>>61530000
i := 0;                                                        << 8500>>61535000
j := -1;  << keeps track of which qualifier is being decoded >><< 8500>>61540000
while i < tfeq'fname'size do                                   << 8500>>61545000
  begin                                                        << 8500>>61550000
  if filename( i ) >= %200                                     << 8500>>61555000
     then begin                                                << 8500>>61560000
          m := 0;  << index into file name qualifiers >>       << 8500>>61565000
          j := j + 1;                                          << 8500>>61570000
          if i <> 0                                            << 8500>>61575000
             then begin                                        << 8500>>61580000
                  for'file'name( l ) := ".";                   << 8500>>61585000
                  l := l + 1;                                  << 8500>>61590000
                  end;                                         << 8500>>61595000
          end;                                                 << 8500>>61600000
                                                               << 8500>>61605000
  case j of                                                    << 8500>>61610000
       begin                                                   << 8500>>61615000
       << 0 >> << file name >>                                 << 8500>>61620000
       if filename( i ) >= %200                                << 8502>>61625000
          then t'filename( m ) := filename( i ) - %200         << 8502>>61630000
          else t'filename( m ) := filename( i );               << 8502>>61635000
                                                               << 8500>>61640000
       << 1 >> << group name >>                                << 8500>>61645000
       if filename( i ) >= %200                                << 8502>>61650000
          then t'group( m ) := filename( i ) - %200            << 8502>>61655000
          else t'group( m ) := filename( i );                  << 8502>>61660000
                                                               << 8500>>61665000
       << 2 >> << account name >>                              << 8500>>61670000
       if filename( i ) <> " "                                 << 8502>>61675000
          then if filename( i ) >= %200                        << 8502>>61680000
                  then t'account( m ) := filename( i ) - %200  << 8502>>61685000
                  else t'account( m ) := filename( i );        << 8502>>61690000
                                                               << 8500>>61695000
       end; << case stmt >>                                    << 8500>>61700000
                                                               << 8500>>61705000
  if filename( i ) >= %200                                     << 8502>>61710000
     then for'file'name( l ) := filename( i ) - %200           << 8502>>61715000
     else for'file'name( l ) := filename( i );                 << 8502>>61720000
  l := l + 1;                                                  << 8502>>61725000
                                                               << 8500>>61730000
  m := m + 1;                                                  << 8500>>61735000
  i := i + 1;                                                  << 8500>>61740000
  end;    << while loop  >>                                    << 8500>>61745000
                                                               << 8502>>61750000
<< before we check the entry from the jdt against what >>      << 8502>>61755000
<< the user desires, we need to see if this is the 1st >>      << 8502>>61760000
<< occurance of the logon group and logon account.  if >>      << 8502>>61765000
<< it is, then we must check for the existence of the  >>      << 8502>>61770000
<< temporary file, $oldpass.  if $oldpass exists, then >>      << 8502>>61775000
<< we will reprocess this jdt entry after the $oldpass >>      << 8502>>61780000
<< is displayed.  sorry...                             >>      << 8502>>61785000
                                                               << 8502>>61790000
if check'needed = true                                         << 8502>>61795000
   then if ( ( bpresult( 38 ) = "@       "        ) land       << 8502>>61800000
             ( w'group        = t'group,(8)       ) land       << 8502>>61805000
             ( w'account      = t'account,(8)     ) )          << 8502>>61810000
           then begin                                          << 8502>>61815000
                check'needed := false;                         << 8502>>61820000
                reprocess := true;                             << 8502>>61825000
                goto oldpass;                                  << 8502>>61830000
                end;                                           << 8502>>61835000
                                                               << 8502>>61840000
                                                               << 8500>>61845000
<< now all three qualifiers are out of the tfeq'entry >>       << 8500>>61850000
<< it must be determined if they match.  all three    >>       << 8500>>61855000
<< must match if we are to get the volume index and   >>       << 8500>>61860000
<< the sector address.                                >>       << 8500>>61865000
                                                               << 8500>>61870000
if((dirmatch( bpresult( 38 ), t'filename ) = 0 ) land          << 8500>>61875000
   (dirmatch( bpresult( 46 ), t'group    ) = 0 ) land          << 8500>>61880000
   (dirmatch( bpresult( 54 ), t'account  ) = 0 ) )             << 8500>>61885000
  then begin                                                   << 8500>>61890000
                                                               << 8500>>61895000
       << we have a match >>                                   << 8500>>61900000
                                                               << 8500>>61905000
       << increment tfeq'entry to vol. and sector words >>     << 8500>>61910000
       @tfeq'entry := (@tfeq'entry + (tfeq'fname'size/2)) + 1; << 8500>>61915000
       volume'index := tfeq'entry.(0:8);                       << 8500>>61920000
       sector0 := tfeq'entry.(8:8);                            << 8500>>61925000
       sector1 := tfeq'entry( 1 );                             << 8500>>61930000
       end                                                     << 8500>>61935000
  else get'tfname := false;  << no match >>                    << 8500>>61940000
                                                               << 8500>>61945000
goto end'get'tfname;                                           << 8502>>61950000
                                                               << 8502>>61955000
oldpass:  get'tfname := handle'oldpass;                        << 8502>>61960000
                                                               << 8502>>61965000
end'get'tfname:                                                << 8502>>61970000
                                                               << 8502>>61975000
end;  << subroutine get'tfname >>                              << 8500>>61980000
$page                                                          << 8500>>61985000
<<                                                           >><< 8500>>61990000
<<***********************************************************>><< 8500>>61995000
<<                                                           >><< 8500>>62000000
<< subroutine print'dump'line                                >><< 8500>>62005000
<<                                                           >><< 8500>>62010000
<< purpose:  to print an octal dump and the ascii equivelent >><< 8500>>62015000
<<           and replace the unprintables by "."             >><< 8500>>62020000
<<                                                           >><< 8500>>62025000
<<***********************************************************>><< 8500>>62030000
                                                               << 8500>>62035000
subroutine print'dump'line( line, len );                       << 8500>>62040000
value len;                                                     << 8500>>62045000
integer len;                                                   << 8500>>62050000
integer array line;                                            << 8500>>62055000
begin                                                          << 8500>>62060000
move ascii'part(0) := line,(len);                              << 8500>>62065000
out'buff( 0 ) := "  ";                                         << 8500>>62070000
move out'buff( 1 ) := out'buff,(27);                           << 8500>>62075000
move ascii'part( len ) := out'buff,( 8 - len );                << 8500>>62080000
count := 0;                                                    << 8500>>62085000
                                                               << 8500>>62090000
<< go through the ascii part and replace unprintable >>        << 8500>>62095000
<< characters with ".".  convert each 16 bit word to >>        << 8500>>62100000
<< octal representation and put into first part of   >>        << 8500>>62105000
<< out'buff                                          >>        << 8500>>62110000
while count < len do                                           << 8500>>62115000
  begin                                                        << 8500>>62120000
  tos := 0;                                                    << 8500>>62125000
  tos := ascii'part'b( count &lsl(1) );                        << 8500>>62130000
  if <                                                         << 8500>>62135000
     then ascii'part'b( x ) := ".";  << an unprintable char >> << 8500>>62140000
  tos := tos &lsl(8);                                          << 8500>>62145000
  tos := ascii'part'b( x + 1 );                                << 8500>>62150000
  if <                                                         << 8500>>62155000
     then ascii'part'b( x ) := "."; << unprintable char >>     << 8500>>62160000
  tos := tos lor tos;                                          << 8500>>62165000
  ascii( *, 8, out'buff'b( count * 7 ));                       << 8500>>62170000
  count := count + 1;                                          << 8500>>62175000
  end;                                                         << 8500>>62180000
fwrite( fnum, out'buff, 38, 0 );                               << 8500>>62185000
                                                               << 8500>>62190000
end;  << subroutine print'dump'line >>                         << 8500>>62195000
$page                                                          << 8500>>62200000
<<***********************************************************>><< 8500>>62205000
<<                                                           >><< 8500>>62210000
<< subroutine format'level'minus'1                           >><< 8500>>62215000
<<                                                           >><< 8500>>62220000
<< purpose:  to display the file label in an octal dump/ascii>><< 8500>>62225000
<<           format.                                         >><< 8500>>62230000
<<                                                           >><< 8500>>62235000
<<***********************************************************>><< 8500>>62240000
                                                               << 8500>>62245000
subroutine format'level'minus'1;                               << 8500>>62250000
begin                                                          << 8500>>62255000
                                                               << 8500>>62260000
<< f = file.group.account line >>                              << 8500>>62265000
format'file'name;                                              << 8500>>62270000
                                                               << 8502>>62275000
already'prt := true;                                           << 8502>>62280000
                                                               << 8500>>62285000
<< format and print the first line of the display.  this >>    << 8500>>62290000
<< includes the name of the file and the sector info     >>    << 8500>>62295000
<< of the file.                                          >>    << 8500>>62300000
                                                               << 8500>>62305000
move first'line'b( 0 ) := t'filename,( 8 );                    << 8500>>62310000
first'line( 4 ) := sector0;                                    << 8500>>62315000
first'line( 5 ) := sector1;                                    << 8500>>62320000
print'dump'line( first'line, 6 );                              << 8500>>62325000
                                                               << 8500>>62330000
                                                               << 8500>>62335000
l := 128;                                                      << 8500>>62340000
while l > 8 do                                                 << 8500>>62345000
  begin                                                        << 8500>>62350000
  print'dump'line(flab( 128 - l ), 8 );                        << 8500>>62355000
  l := l - 8;                                                  << 8500>>62360000
  end;                                                         << 8500>>62365000
if l > 0                                                       << 8500>>62370000
   then print'dump'line( flab( 128 - l ), l );                 << 8500>>62375000
                                                               << 8500>>62380000
end;  << subroutin format'level'minus'1 >>                     << 8500>>62385000
                                                               << 8500>>62390000
$page                                                          << 8500>>62395000
<<***********************************************************>><< 8500>>62400000
<<                                                           >><< 8500>>62405000
<< subroutine write'banner                                   >><< 8500>>62410000
<<                                                           >><< 8500>>62415000
<< purpose:  to move t'account and t'group in to b'head1 and >><< 8500>>62420000
<<           to print the four lines of the banner.          >><< 8500>>62425000
<<                                                           >><< 8500>>62430000
<<***********************************************************>><< 8500>>62435000
                                                               << 8500>>62440000
subroutine write'banner;                                       << 8500>>62445000
                                                               << 8500>>62450000
begin                                                          << 8500>>62455000
                                                               << 8500>>62460000
fwrite( fnum, b'line, 2, 0 );                                  << 8500>>62465000
                                                               << 8500>>62470000
move b'head1( 10 ) := t'account,(8);                           << 8500>>62475000
move b'head1( 30 ) := t'group,( 8 );                           << 8502>>62480000
                                                               << 8500>>62485000
fwrite( fnum, head1, 20, 0 );                                  << 8500>>62490000
fwrite( fnum, b'line, 2, 0 );                                  << 8500>>62495000
if list'level = 2                                              << 8500>>62500000
   then begin                                                  << 8500>>62505000
        << append and write headings for level 2 >>            << 8500>>62510000
        init'buff;                                             << 8500>>62515000
        move out'buff'b( 0 ) := b'head2,( 51 );                << 8500>>62520000
        move out'buff'b( 50 ) := b'head22,( 18 );              << 8502>>62525000
        fwrite( fnum, out'buff, 38, 0 );                       << 8500>>62530000
        init'buff;                                             << 8500>>62535000
        move out'buff'b( 18 ) := b'head3,( 33 );               << 8500>>62540000
        move out'buff'b( 50 ) := b'head32,( 18 );              << 8502>>62545000
        fwrite( fnum, out'buff, 38, 0 );                       << 8500>>62550000
        end                                                    << 8500>>62555000
   else begin                                                  << 8500>>62560000
        << write the heading for level 1 >>                    << 8500>>62565000
        fwrite( fnum, head2, 26, 0 );                          << 8500>>62570000
                                                               << 8500>>62575000
        init'buff;                                             << 8500>>62580000
        move out'buff'b( 18 ) := b'head3,( 33 );               << 8500>>62585000
        fwrite( fnum, out'buff, 38, 0 );                       << 8500>>62590000
        end;                                                   << 8500>>62595000
                                                               << 8500>>62600000
end;  << subroutine write'banner >>                            << 8500>>62605000
$page                                                          << 8500>>62610000
<<***********************************************************>><< 8500>>62615000
<<                                                           >><< 8500>>62620000
<< subroutine format'level'0                                 >><< 8500>>62625000
<<                                                           >><< 8500>>62630000
<< purpose:  to control the output of temporary file name in >><< 8500>>62635000
<<           list'level = 0 format.  each file is printed    >><< 8500>>62640000
<<           linearly, one fully qualified file name per     >><< 8500>>62645000
<<           line.                                           >><< 8500>>62650000
<<                                                           >><< 8500>>62655000
<<***********************************************************>><< 8500>>62660000
                                                               << 8500>>62665000
subroutine format'level'0;                                     << 8500>>62670000
begin                                                          << 8500>>62675000
                                                               << 8500>>62680000
<< for'file'name (from subroutine get'tfname) for the name   >><< 8500>>62685000
<< of the file.   tfeq'fname'size is used for the length     >><< 8500>>62690000
                                                               << 8500>>62695000
                                                               << 8500>>62700000
init'buff;                                                     << 8500>>62705000
move out'buff'b( 0 ) := for'file'name,( 26 );                  << 8502>>62710000
fwrite( fnum, out'buff, 38, 0 );                               << 8500>>62715000
end;                                                           << 8500>>62720000
$page                                                          << 8500>>62725000
<<**********************************************************>> << 8500>>62730000
<<                                                          >> << 8500>>62735000
<< subroutine format'level'1'2                              >> << 8500>>62740000
<<                                                          >> << 8500>>62745000
<< purpose:  to print list'level = 1 information about a    >> << 8500>>62750000
<<           temporary file.                                >> << 8500>>62755000
<<                                                          >> << 8500>>62760000
<<**********************************************************>> << 8500>>62765000
                                                               << 8500>>62770000
subroutine format'level'1'2;                                   << 8500>>62775000
begin                                                          << 8500>>62780000
                                                               << 8500>>62785000
<< if the last group or the last account printed >>            << 8500>>62790000
<< do not match the current group or account,    >>            << 8500>>62795000
<< post a new banner before printing the info.   >>            << 8500>>62800000
                                                               << 8500>>62805000
if t'group <> b'head1( 30 ),( 8 ) or                           << 8502>>62810000
   t'account <> b'head1(10),(8)                                << 8500>>62815000
   then write'banner;                                          << 8500>>62820000
init'buff;                                                     << 8500>>62825000
                                                               << 8500>>62830000
l := 0;                                                        << 8500>>62835000
move out'buff'b( l ) := t'filename( 0 ),( 8 );                 << 8500>>62840000
l := l + 8;                                                    << 8500>>62845000
                                                               << 8500>>62850000
<< if file is opened, then post an "*" >>                      << 8500>>62855000
if file'open                                                   << 8500>>62860000
   then move out'buff'b( l ) := "*";                           << 8500>>62865000
l := l + 2;                                                    << 8502>>62870000
                                                               << 8500>>62875000
<< get the file code and the mnemonic if possible.  if the >>  << 8500>>62880000
<< file code is negative, move "PRIV" into the buffer.  if >>  << 8500>>62885000
<< the file code is > 0 see if the code is hp reserved, if >>  << 8500>>62890000
<< so the mnemonic will be placed in the buffer.  if the   >>  << 8500>>62895000
<< file code = 0, it still may be a ksam file so check and >>  << 8500>>62900000
<< move "KSAM" into the buffer, else leave it blank for 0. >>  << 8500>>62905000
                                                               << 8500>>62910000
if flfilecode < 0                                              << 8500>>62915000
   then move out'buff'b( l ) := priv'mnemonic,( 5 )            << 8500>>62920000
   else if flfilecode > 0                                      << 8500>>62925000
           then begin                                          << 8500>>62930000
                get'filemnemonic( flfilecode,                  << 8500>>62935000
                                  out'buff'b( l ),             << 8500>>62940000
                                  fl'mnemonic'len );           << 8500>>62945000
                if <>                                          << 8500>>62950000
                   then ascii(flfilecode,-10,out'buff'b(l+3)); << 8500>>62955000
                end                                            << 8500>>62960000
           else if flksam                                      << 8500>>62965000
                   then move out'buff'b( l ) := ksam,( 5 );    << 8500>>62970000
                                                               << 8500>>62975000
l := l + 11;                                                   << 8500>>62980000
                                                               << 8500>>62985000
<< post the record size and the type >>                        << 8500>>62990000
                                                               << 8500>>62995000
<< the record size is stored negative>>                        << 8500>>63000000
<< and in bytes.                     >>                        << 8500>>63005000
if flascii = 0                                                 << 8500>>63010000
   then begin                                                  << 8500>>63015000
        << a binary file >>                                    << 8500>>63020000
       tos := -flrecsize;                                      << 8500>>63025000
       << convert to words >>                                  << 8500>>63030000
       tos := tos & asr(1);                                    << 8500>>63035000
       rsize := tos;                                           << 8500>>63040000
       move out'buff'b( l ) := "W";                            << 8500>>63045000
       end                                                     << 8500>>63050000
  else begin                                                   << 8500>>63055000
       rsize := -flrecsize;                                    << 8500>>63060000
       move out'buff'b( l ) := "B";                            << 8500>>63065000
       end;                                                    << 8500>>63070000
                                                               << 8500>>63075000
if flformat = 1     << a variable record length >>             << 8500>>63080000
      and           <<            and           >>             << 8500>>63085000
   not flmsgfile    << not a message file then  >>             << 8500>>63090000
   then begin                                                  << 8500>>63095000
        rsize := rsize - 2;                                    << 8500>>63100000
        if flascii = 1                                         << 8500>>63105000
           then rsize := rsize - 2;                            << 8500>>63110000
        end;                                                   << 8500>>63115000
                                                               << 8500>>63120000
ascii( rsize, -10, out'buff'b( l - 1) );                       << 8500>>63125000
                                                               << 8500>>63130000
l := l + 3;                                                    << 8500>>63135000
                                                               << 8500>>63140000
<< post the format of the records >>                           << 8500>>63145000
case flformat of                                               << 8500>>63150000
                                                               << 8500>>63155000
     begin                                                     << 8500>>63160000
                                                               << 8500>>63165000
     << 0 >> << fixed >>                                       << 8500>>63170000
     move out'buff'b( l ) := "F";                              << 8500>>63175000
                                                               << 8500>>63180000
     << 1 >> << variable >>                                    << 8500>>63185000
     move out'buff'b( l ) := "V";                              << 8500>>63190000
                                                               << 8500>>63195000
     << 2 >> << undefined >>                                   << 8500>>63200000
     move out'buff'b( l ) := "U";                              << 8500>>63205000
                                                               << 8500>>63210000
     end;                                                      << 8500>>63215000
                                                               << 8500>>63220000
l := l + 1;                                                    << 8500>>63225000
                                                               << 8500>>63230000
<< post the binary or the ascii >>                             << 8500>>63235000
case flascii of                                                << 8500>>63240000
                                                               << 8500>>63245000
     begin                                                     << 8500>>63250000
                                                               << 8500>>63255000
     << 0 >> << binary >>                                      << 8500>>63260000
     move out'buff'b( l ) := "B";                              << 8500>>63265000
                                                               << 8500>>63270000
     << 1 >> << ascii >>                                       << 8500>>63275000
     move out'buff'b( l ) := "A";                              << 8500>>63280000
                                                               << 8500>>63285000
     end;                                                      << 8500>>63290000
                                                               << 8500>>63295000
l := l + 1;                                                    << 8500>>63300000
                                                               << 8500>>63305000
<< post information on cctl >>                                 << 8500>>63310000
if flcontrol = 1                                               << 8500>>63315000
   then begin                                                  << 8500>>63320000
        move out'buff'b( l ) := "C";                           << 8500>>63325000
        l := l + 1;                                            << 8500>>63330000
        end;                                                   << 8500>>63335000
                                                               << 8500>>63340000
<< post the file type >>                                       << 8500>>63345000
case flfiletype of                                             << 8500>>63350000
                                                               << 8500>>63355000
     begin                                                     << 8500>>63360000
                                                               << 8500>>63365000
     << 0 >> << standard          >>                           << 8500>>63370000
     ;                                                         << 8500>>63375000
                                                               << 8500>>63380000
     << 1 >> << reserved for ksam >>                           << 8500>>63385000
     ;                                                         << 8500>>63390000
                                                               << 8500>>63395000
     << 2 >> <<   rio             >>                           << 8500>>63400000
     move out'buff'b( l ) := "R";                              << 8500>>63405000
                                                               << 8500>>63410000
     << 3 >> << not assigned      >>                           << 8500>>63415000
     ;                                                         << 8500>>63420000
                                                               << 8500>>63425000
     << 4 >> << circular file     >>                           << 8500>>63430000
     move out'buff'b( l ) := "O";                              << 8500>>63435000
                                                               << 8500>>63440000
     << 5 >> << not assigned      >>                           << 8500>>63445000
     ;                                                         << 8500>>63450000
                                                               << 8500>>63455000
     << 6 >> << message file      >>                           << 8500>>63460000
     move out'buff'b( l ) := "M";                              << 8500>>63465000
                                                               << 8500>>63470000
     end;                                                      << 8500>>63475000
                                                               << 8500>>63480000
if flcontrol = 1                                               << 8500>>63485000
   then l := l + 10                                            << 8500>>63490000
   else l := l + 11;                                           << 8500>>63495000
                                                               << 8500>>63500000
<< print the eof of the file >>                                << 8500>>63505000
i := dascii( fleof, 10, first'line'b );                        << 8500>>63510000
move out'buff'b( l - i + 1 ) := first'line'b( 0 ),( i );       << 8500>>63515000
                                                               << 8500>>63520000
l := l + 11;                                                   << 8500>>63525000
                                                               << 8500>>63530000
<< print the limit of the file >>                              << 8500>>63535000
i := dascii( flflim, 10, first'line'b );                       << 8500>>63540000
move out'buff'b( l - i + 1 ) := first'line'b( 0 ),( i );       << 8500>>63545000
                                                               << 8500>>63550000
l := l + 2;                                                    << 8500>>63555000
                                                               << 8500>>63560000
if list'level = 2                                              << 8500>>63565000
   then begin                                                  << 8500>>63570000
                                                               << 8500>>63575000
        l := l + 2;                                            << 8500>>63580000
                                                               << 8500>>63585000
        << need records/block, number of sectors, number of >> << 8500>>63590000
        << extents, and number of extents allocated.        >> << 8500>>63595000
                                                               << 8500>>63600000
        << compute records/block >>                            << 8500>>63605000
        tos := double( flblksize );                            << 8500>>63610000
        tos := flrecsize;                                      << 8500>>63615000
        if =                                                   << 8500>>63620000
           then tos := tos + 128                               << 8500>>63625000
           else if <                                           << 8500>>63630000
                   then tos := (-tos + 1) & lsr(1);            << 8500>>63635000
        if flmsgfile                                           << 8500>>63640000
           then tos := tos + 3;  << add msg file header >>     << 8500>>63645000
        assemble( ldiv, del );                                 << 8500>>63650000
        rec'size := tos;                                       << 8500>>63655000
        ascii( rec'size, -10, out'buff'b( l ) );               << 8500>>63660000
                                                               << 8500>>63665000
        l := l + 12;                                           << 8500>>63670000
                                                               << 8500>>63675000
        << compute the number of extents  >>                   << 8500>>63680000
        << that are being used.           >>                   << 8500>>63685000
        << flnumexts are max. # extents - 1 >>                 << 8502>>63690000
        max'exts := flnumexts;                                 << 8500>>63695000
        extent'map( 0 ) := 0;                                  << 8500>>63700000
        move extent'map( 1 ) := extent'map(0),(63);            << 8502>>63705000
        move extent'map( 0 ) := flextmap,( (max'exts+1) * 2 ); << 8502>>63710000
        m := 0;                                                << 8500>>63715000
        << find the number of extents being used >>            << 8500>>63720000
        num'extents'used := 0;                                 << 8500>>63725000
        while ( m <= integer( max'exts )) do                   << 8500>>63730000
           begin                                               << 8500>>63735000
           if dextent'map( m ) <> 0d                           << 8500>>63740000
              then num'extents'used := num'extents'used + 1;   << 8500>>63745000
           m := m + 1;                                         << 8500>>63750000
           end;                                                << 8500>>63755000
                                                               << 8500>>63760000
                                                               << 8500>>63765000
        << post number of extents used >>                      << 8500>>63770000
        ascii( num'extents'used, -10, out'buff'b( l ) );       << 8500>>63775000
                                                               << 8500>>63780000
                                                               << 8500>>63785000
        l := l + 3;                                            << 8500>>63790000
                                                               << 8500>>63795000
        << post the number of max. extents >>                  << 8500>>63800000
        ascii( max'exts + 1, -10, out'buff'b( l ) );           << 8500>>63805000
                                                               << 8500>>63810000
        << compute the sector information >>                   << 8500>>63815000
        if dextent'map( max'exts ) = 0d                        << 8500>>63820000
           then tos := logical( num'extents'used )             << 8500>>63825000
                       **logical( flextsize )                  << 8500>>63830000
           else tos := ( logical( num'extents'used ) -1 )      << 8500>>63835000
                       **logical( flextsize ) +                << 8500>>63840000
                       double(logical(fllastextsize));         << 8500>>63845000
                                                               << 8500>>63850000
        << post the sector information >>                      << 8500>>63855000
        m := dascii( *, 10, first'line'b );                    << 8765>>63860000
        move out'buff'b( l - 6 - m + 1 ) := first'line'b( 0 ), << 8500>>63865000
                                            ( m );             << 8500>>63870000
                                                               << 8500>>63875000
                                                               << 8500>>63880000
        l := l + 2;                                            << 8500>>63885000
       end;  << if list'level = 2 >>                           << 8500>>63890000
                                                               << 8500>>63895000
                                                               << 8500>>63900000
move out'buff'b( l ) := "(TEMP)";                              << 8500>>63905000
                                                               << 8500>>63910000
fwrite( fnum, out'buff, 38 , 0 );                              << 8500>>63915000
                                                               << 8500>>63920000
end; << subroutine format'level'1'2 >>                         << 8500>>63925000
$page                                                          << 8921>>63930000
<< *********************************************************** << 8921>>63935000
<<                                                             << 8921>>63940000
<< subroutine get'file'label                                   << 8921>>63945000
<<                                                             << 8921>>63950000
<< purpose: to return the file label of the temporary file     << 8921>>63955000
<<          from the directory.  check to see if file was      << 8921>>63960000
<<          created under a user on a private volume.  may     << 8921>>63965000
<<          need to mount a volume.                            << 8921>>63970000
<<                                                             << 8921>>63975000
<< *********************************************************** << 8921>>63980000
                                                               << 8921>>63985000
logical subroutine get'file'label;                             << 8921>>63990000
begin                                                          << 8921>>63995000
get'file'label := 1;  << must equal 0 if we get label >>       << 8921>>64000000
success'mount := true;                                         << 8921>>64005000
pvinfo := 0;                                                   << 8921>>64010000
file'info( 0 ) := -1;                                          << 8921>>64015000
move file'info( 1 ) := file'info( 0 ),( 3 );                   << 8921>>64020000
                                                               << 8921>>64025000
<< returns true if the file label is successfully retreived >> << 8921>>64030000
                                                               << 8921>>64035000
<< see if group and account is on a pv.  if so, attempt to >>  << 8921>>64040000
<< mount.  if it mounts, pvinfo.(4:4) will contain the     >>  << 8921>>64045000
<< mounted volume table index used to get the correct ldev >>  << 8921>>64050000
direc'error := direcfind( %10, 0d, t'account'l, t'group'l,     << 8921>>64055000
                          t'filename'l, group'entry'array );   << 8921>>64060000
                                                               << 8921>>64065000
if group'entry'array( glinkage ).(pvf) = pv then               << 8921>>64070000
   begin                                                       << 8921>>64075000
   mount( star, t'group, t'account, mount'req, -1, pvinfo );   << 8921>>64080000
   if <>                                                       << 8921>>64085000
      then begin                                               << 8921>>64090000
           success'mount := false;                             << 8921>>64095000
           cierr( -listfflabioerr );                           << 8921>>64100000
           end;                                                << 8921>>64105000
   end;                                                        << 8921>>64110000
                                                               << 8921>>64115000
if success'mount = true                                        << 8921>>64120000
   then begin                                                  << 8921>>64125000
        ldev := lun( volume'index, mvtabx );                   << 8921>>64130000
        tos  := flabio( ldev, sector, 0, flab );               << 8921>>64135000
        if tos <> 0                                            << 8921>>64140000
           then cierr( -listfflabioerr )                       << 8921>>64145000
           else get'file'label := 0;                           << 8921>>64150000
        if group'entry'array( glinkage ).( pvf ) = pv          << 9001>>64155000
            then dismount( star, t'group, t'account,           << 8921>>64160000
                                  two, pvinfo );               << 8921>>64165000
                                                               << 8921>>64170000
       end;                                                    << 8921>>64175000
end;   << subroutine get'file'label >>                         << 8921>>64180000
$page                                                          << 8500>>64185000
<<**********************************************************>> << 8500>>64190000
<<                                                          >> << 8500>>64195000
<< subroutine format'file'info                              >> << 8500>>64200000
<<                                                          >> << 8500>>64205000
<< purpose:  1.  get the file label.                        >> << 8500>>64210000
<<           2.  drive the formatting of the file           >> << 8500>>64215000
<<               information depending upon list'level.     >> << 8500>>64220000
<<           3.  control the printing of the correct banner >> << 8500>>64225000
<<               at the correct time.                       >> << 8500>>64230000
<<                                                          >> << 8500>>64235000
<<**********************************************************>> << 8500>>64240000
                                                               << 8500>>64245000
subroutine format'file'info;                                   << 8500>>64250000
begin                                                          << 8500>>64255000
                                                               << 8500>>64260000
                                                               << 8500>>64265000
<< get the file label if list'level <> 0 >>                    << 8921>>64270000
if list'level = 0                                              << 8921>>64275000
   then format'level'0                                         << 8921>>64280000
   else begin                                                  << 8921>>64285000
                                                               << 8921>>64290000
        tos := get'file'label;                                 << 8921>>64295000
        if tos = 0                                             << 8921>>64300000
           then case ( list'level + 1  ) of                    << 8921>>64305000
                     begin                                     << 8921>>64310000
                     << 0 >> << level -1 format >>             << 8921>>64315000
                     format'level'minus'1;                     << 8921>>64320000
                                                               << 8921>>64325000
                     << 1 >> << level 0 format  >>             << 8921>>64330000
                     ;       << spoken for      >>             << 8921>>64335000
                                                               << 8921>>64340000
                     << 2 >> << level 1 format  >>             << 8921>>64345000
                     format'level'1'2;                         << 8921>>64350000
                                                               << 8921>>64355000
                     << 3 >> << level 2 format  >>             << 8921>>64360000
                     format'level'1'2;                         << 8921>>64365000
                                                               << 8921>>64370000
                     end;                                      << 8921>>64375000
        end;  << list'level <> 0 >>                            << 8921>>64380000
                                                               << 8921>>64385000
end;   << subroutine format'file'info >>                       << 8921>>64390000
$page                                                          << 8500>>64395000
<<***********************************************************>><< 8500>>64400000
<<                                                           >><< 8500>>64405000
<< subroutine close'list'file                                >><< 8500>>64410000
<<                                                           >><< 8500>>64415000
<< purpose:  to close any user specified listfile            >><< 8500>>64420000
<<           as a temporary file.                            >><< 8500>>64425000
<<                                                           >><< 8500>>64430000
<<***********************************************************>><< 8500>>64435000
                                                               << 8500>>64440000
subroutine close'list'file;                                    << 8500>>64445000
begin                                                          << 8500>>64450000
<< post a blank line >>                                        << 8500>>64455000
if already'prt = true                                          << 8502>>64460000
   then fwrite( fnum, b'line, 2, 0 );                          << 8500>>64465000
                                                               << 8500>>64470000
if not stdlist                                                 << 8500>>64475000
   then begin                                                  << 8500>>64480000
        fclose( fnum, fclose'options, 0 );                     << 8500>>64485000
        if <>                                                  << 8500>>64490000
           then begin                                          << 8500>>64495000
                ferror'( fnum, parmnum );                      << 8500>>64500000
                cierr( errnum := listffserr, listfile,         << 8500>>64505000
                                 %10000, parmnum );            << 8500>>64510000
                end;                                           << 8500>>64515000
       end;                                                    << 8500>>64520000
end;  << subroutine close'list'file >>                         << 8500>>64525000
$page                                                          << 8500>>64530000
$page                                                          << 8500>>64535000
<<***********************************************************>><< 8502>>64540000
<<                                                             << 8502>>64545000
<< subroutine print'driver                                     << 8502>>64550000
<<                                                             << 8502>>64555000
<< purpose:   to drive the printing of the header and the      << 8502>>64560000
<<            formatting of the information.                   << 8502>>64565000
<<                                                             << 8502>>64570000
<<***********************************************************>><< 8502>>64575000
                                                               << 8502>>64580000
subroutine print'driver;                                       << 8502>>64585000
                                                               << 8502>>64590000
begin                                                          << 8502>>64595000
<< post user.account,loggroup  >>                              << 8502>>64600000
                                                               << 8502>>64605000
if (( list'level > -1     ) land                               << 8502>>64610000
    ( already'prt = false ) )                                  << 8502>>64615000
    then begin                                                 << 8502>>64620000
         fwrite( fnum, b'line, 2, 0 );                         << 8502>>64625000
         format'user;                                          << 8502>>64630000
         fwrite( fnum, heading'l, -46, 0 );                    << 8502>>64635000
         if list'level = 0                                     << 8502>>64640000
             then fwrite( fnum, b'line, 2, 0 );                << 8502>>64645000
         already'prt := true;                                  << 8502>>64650000
         end;                                                  << 8502>>64655000
format'file'info;  << display info >>                          << 8502>>64660000
end;  << subroutine print'driver >>                            << 8502>>64665000
$page                                                          << 8502>>64670000
<<***********************************************************>><< 8502>>64675000
<<                                                            ><< 8500>>64680000
<< subroutine format'temp'files                               ><< 8500>>64685000
<<                                                            ><< 8500>>64690000
<< purpose:  to format the temporary files in the user's      ><< 8500>>64695000
<<           desired format.                                  ><< 8500>>64700000
<<                                                            ><< 8500>>64705000
<<************************************************************><< 8500>>64710000
                                                               << 8500>>64715000
subroutine format'temp'files;                                  << 8500>>64720000
begin                                                          << 8500>>64725000
                                                               << 8500>>64730000
fgetinfo( fnum, , foptions, , , dev );                         << 8500>>64735000
                                                               << 8500>>64740000
<< print time stamp if we have a job or a listfile >>          << 8500>>64745000
pxglobal;                                                      << 8500>>64750000
interactive := pxg'interactive;                                << 8500>>64755000
if not interactive and stdlist                                 << 8500>>64760000
             or                                                << 8500>>64765000
   not interactive and dev >= 8                                << 8500>>64770000
   then begin                                                  << 8500>>64775000
        if not interactive and foptions.(10:3) = f'stdlist     << 8500>>64780000
           then pageeject;                                     << 8500>>64785000
        date'line( datebuf );                                  << 8500>>64790000
        fwrite( fnum, datebuf, -27, %60 );                     << 8500>>64795000
        end;                                                   << 8500>>64800000
                                                               << 8500>>64805000
<< we want to whirl through the jdt matching files with >>     << 8500>>64810000
<< ppresult.  we want to get the file's file label and  >>     << 8500>>64815000
<< print the appropriate information depending upon the >>     << 8500>>64820000
<< list'level                                           >>     << 8500>>64825000
<< (of course this sounds easier than it is done)       >>     << 8500>>64830000
<<                                                      >>     << 8500>>64835000
<< ppresult was obtained through produceparms.  we are  >>     << 8500>>64840000
<< matching ppresult(19) for filename, ppresult(23) for >>     << 8500>>64845000
<< group name and ppresult(27) for account name.        >>     << 8500>>64850000
<<                                                      >>     << 8500>>64855000
                                                               << 8500>>64860000
<< get the jdt full of information                      >>     << 8500>>64865000
movejdt( jdtarr );                                             << 8765>>64870000
                                                               << 8500>>64875000
who( , , , ,w'group, w'account ); << who are we? >>            << 8502>>64880000
                                                               << 8500>>64885000
<< initialize for'file'name with group and acct in case  >>    << 9001>>64890000
<< $oldpass is the first file                            >>    << 9001>>64895000
                                                               << 9001>>64900000
move for'file'name( 0 ) := " ";                                << 9001>>64905000
move for'file'name( 1 ) := for'file'name( 0 ),( 25 );          << 9001>>64910000
move for'file'name( 8 ) := ".";                                << 9001>>64915000
i := 0;                                                        << 9001>>64920000
m := 9;                                                        << 9001>>64925000
while (i < 8 land w'group( i ) <> " ") do                      << 9001>>64930000
   begin                                                       << 9001>>64935000
   move for'file'name( m ) := w'group( i ),( 1 );              << 9001>>64940000
   i := i + 1;                                                 << 9001>>64945000
   m := m + 1;                                                 << 9001>>64950000
   end;                                                        << 9001>>64955000
for'file'name( m ) := ".";                                     << 9001>>64960000
m := m + 1;                                                    << 9001>>64965000
i := 0;                                                        << 9001>>64970000
while ( i < 8 land w'account( i ) <> " ") do                   << 9001>>64975000
   begin                                                       << 9001>>64980000
   move for'file'name( m ) := w'account( i ),( 1 );            << 9001>>64985000
   i := i + 1;                                                 << 9001>>64990000
   m := m + 1;                                                 << 9001>>64995000
   end;                                                        << 9001>>65000000
                                                               << 9001>>65005000
move t'account(0) := w'account( 0 ),(8);                       << 9001>>65010000
move t'group( 0 ) := w'group( 0 ),(8);                         << 9001>>65015000
                                                               << 8500>>65020000
<< set head and tail pointers                           >>     << 8500>>65025000
@tfeq'head := jdtjtfdptr;                                      << 8500>>65030000
@tfeq'tail := jdtjtfeqptr;                                     << 8500>>65035000
                                                               << 8502>>65040000
reprocess    := false;                                         << 8502>>65045000
check'needed := true;                                          << 8502>>65050000
already'prt  := false;                                         << 8502>>65055000
                                                               << 8502>>65060000
if @tfeq'head = @tfeq'tail                                     << 8500>>65065000
   then if handle'oldpass = false   << no $oldpass >>          << 8502>>65070000
           then cierr( errnum := -listftempnotfeqs )           << 8500>>65075000
           else print'driver  << handles heading/formatting >> << 8502>>65080000
   else begin                                                  << 8500>>65085000
                                                               << 8500>>65090000
                                                               << 8500>>65095000
        << tfeq'entry pointing at the first tfeq >>            << 8500>>65100000
        << start of q relative array jdtarr is  >>             << 8500>>65105000
        << is added.                            >>             << 8500>>65110000
        @tfeq'entry := @tfeq'head + @jdtarr;                   << 8500>>65115000
        @tfeq'tail  := @tfeq'tail + @jdtarr;                   << 8500>>65120000
                                                               << 8500>>65125000
        << loop on tfeq'entry until @tfeq'entry = >>           << 8500>>65130000
        << @tfeq'tail.  files will be formatted >>             << 8500>>65135000
                                                               << 8500>>65140000
        while( @tfeq'entry < @tfeq'tail ) do                   << 8500>>65145000
          begin                                                << 8500>>65150000
          @save'tfeq'entry := @tfeq'entry;                     << 8500>>65155000
                                                               << 8500>>65160000
          << entry size is in words >>                         << 8500>>65165000
          tfeq'entry'size := tfeq'entry.(0:8);                 << 8500>>65170000
          init'buff;                                           << 8500>>65175000
          << if we have a temporary file that the user >>      << 8921>>65180000
          << desires, call the formatting subroutine,  >>      << 8921>>65185000
          << print'driver.                             >>      << 8921>>65190000
          if get'tfname = true                                 << 8502>>65195000
             then print'driver;                                << 8502>>65200000
          if reprocess = false                                 << 8502>>65205000
          << a reprocess takes effect if $oldpass was  >>      << 8921>>65210000
          << processed instead of the temporary file.  >>      << 8921>>65215000
          << this will happen if the group and/or the  >>      << 8921>>65220000
          << account of the temporary file is different>>      << 8921>>65225000
          << than that of the previously processed     >>      << 8921>>65230000
          << temporary file.  $oldpass is always       >>      << 8921>>65235000
          << checked after a new group and/or account  >>      << 8921>>65240000
          << is detected.                              >>      << 8921>>65245000
             then @tfeq'entry:=@save'tfeq'entry+tfeq'entry'size<< 8502>>65250000
             else reprocess := false;  << flop flag back >>    << 8502>>65255000
          end;    << while statement >>                        << 8500>>65260000
                                                               << 8500>>65265000
        if already'prt = false                                 << 8502>>65270000
           then cierr( errnum := -listftempnotfound );         << 8502>>65275000
        end  << else begin      >>                             << 8500>>65280000
                                                               << 8500>>65285000
end;                                                           << 8500>>65290000
$page                                                          << 8500>>65295000
                                                               << 8500>>65300000
<<            ***********************                        >><< 8500>>65305000
<<            **                   **                        >><< 8500>>65310000
<<            ** m a i n   b o d y **                        >><< 8500>>65315000
<<            **                   **                        >><< 8500>>65320000
<<            ***********************                        >><< 8500>>65325000
                                                               << 8500>>65330000
<< initialize parms and various other arrays >>                << 8500>>65335000
move b'line := "    ";                                         << 8500>>65340000
move b'head1 :=                                                << 8500>>65345000
   "ACCOUNT=              GROUP=            ";                 << 8502>>65350000
move b'head2 :=                                                << 8500>>65355000
   "FILENAME  CODE  ------------LOGICAL RECORD--------  ";     << 8502>>65360000
move b'head22 :=                                               << 8500>>65365000
   "---  ----SPACE----";                                       << 8500>>65370000
move b'head3 :=                                                << 8500>>65375000
   "SIZE  TYP        EOF      LIMIT   ";                       << 8502>>65380000
move b'head32 :=                                               << 8500>>65385000
   "R/B  SECTORS #X MX";                                       << 8500>>65390000
                                                               << 8500>>65395000
move priv'mnemonic := "PRIV ";                                 << 8500>>65400000
move ksam := "KSAM ";                                          << 8500>>65405000
                                                               << 8500>>65410000
parms := 0d;                                                   << 8500>>65415000
tos := @parms+2;   << address of here to start initializing >> << 8500>>65420000
tos := @parms+1;   << address where the zero is coming from >> << 8500>>65425000
tos := 6;          << number of words to initialize         >> << 8500>>65430000
assemble( move );  << move the zero to six words            >> << 8500>>65435000
                                                               << 8500>>65440000
<< parse the listftemp command                              >> << 8500>>65445000
<<**********************************************************>> << 8500>>65450000
<< the syntax is as follows:                                >> << 8500>>65455000
<<                                                          >> << 8500>>65460000
<<                                 0                        >> << 8500>>65465000
<<           :listftemp [fileset][,1][;listfile]            >> << 8500>>65470000
<<                                 2                        >> << 8500>>65475000
<<                                -1                        >> << 8500>>65480000
<<                                                          >> << 8500>>65485000
<<**********************************************************>> << 8500>>65490000
<<                                                          >> << 8500>>65495000
<< we keep the jir throughout the processing to keep other  >> << 8500>>65500000
<< members of the process tree from purging temporary files >> << 8500>>65505000
<<                                                          >> << 8500>>65510000
                                                               << 8500>>65515000
jir := lockjir;                                                << 8500>>65520000
mycommand(parmsp,dl,4,numparms,parms);                         << 8500>>65525000
parmnum := 1;                                                  << 8500>>65530000
if not produceparms( 0, parmsp, ppresult, delim, errnum)       << 8500>>65535000
   then begin                                                  << 8502>>65540000
        unlockjir( jir );                                      << 8502>>65545000
        return;                                                << 8502>>65550000
        end;     << begin if parsing error >>                  << 8502>>65555000
if ( numparms > 0 ) and  <<not just a cr>>                     << 8500>>65560000
   (@delim < @leafname+integer(leafnamelen))                   << 8500>>65565000
   then begin  << extraneous stuff in leafname >>              << 8500>>65570000
        tos := errnum := listfextraneous;                      << 8500>>65575000
        tos := @delim;                                         << 8500>>65580000
        cierr( *, * );                                         << 8500>>65585000
        unlockjir( jir );                                      << 8502>>65590000
        return;                                                << 8500>>65595000
        end;                                                   << 8500>>65600000
                                                               << 8500>>65605000
if numparms = 0                                                << 8500>>65610000
   then leafnamechar := cr;                                    << 8500>>65615000
                                                               << 8500>>65620000
if list'level'ok = true                   << get list'level  >><< 8502>>65625000
   then if list'file'ok = true            << get list'file   >><< 8502>>65630000
           then begin                                          << 8500>>65635000
                format'temp'files;        << print fileinfo  >><< 8502>>65640000
                close'list'file;          << close list'file >><< 8502>>65645000
                end;                                           << 8500>>65650000
                                                               << 8500>>65655000
unlockjir( jir );                                              << 8500>>65660000
end;  <<cxlistftemp>>                                          << 8500>>65665000
$control segment=main                                          << 8500>>65670000
end.                                                           << 8500>>65675000
