Trailing-Edge
-
PDP-10 Archives
-
decuslib20-09
-
decus/20-183/ansimt.lst
There are no other files named ansimt.lst in the archive.
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 1
1 { }
2 { A N S I M T . P A S L O G - }
3 { }
4 { }
5 { Revision 85/07/85 10:00:00 Nelson Kanemoto }
6 { Modified to run with new version of Rutgers Pascal. Modifications }
7 { were passing constants by value by removing the 'var' off the fol- }
8 { lowing procedures: scopy, ctoi, GarbageErr, and WarnMess. }
9 { }
10 { Installation 85/03/08 12:45:00 Nelson Kanemoto }
11 { Latest version installed in PS:<UHCCSYS-SUBSYS> }
12 { }
13 { Revision 85/02/15 12:00:00 Nelson Kanemoto }
14 { Added warning messages for EBCDIC and DEC-20 labelled tapes for }
15 { the TAPE command. }
16 { }
17 { Installation 85/01/17 10:45:00 Nelson Kanemoto }
18 { Latest version installed in PS:<UHCCSYS-SUBSYS> }
19 { }
20 { Revision 85/01/15 16:00:00 Nelson Kanemoto }
21 { Installed a modified ansimt.doc into doc:, with modifications on }
22 { wildcards for the STORE and RESTORE commands }
23 { }
24 { Revision 85/01/09 12:00:00 Nelson Kanemoto }
25 { Restore command with wildcards is now working, but changed bits }
26 { in gjgen in ParseRestore1. }
27 { }
28 { Revision 84/12/26 14:00:00 Nelson Kanemoto }
29 { Started working on procedure RestoreFile by extracting from }
30 { ProcessRestore. }
31 { }
32 { Revision 84/12/26 13:00:00 Nelson Kanemoto }
33 { Working on wildcards for the restore command, modifying procedures }
34 { ParseRestore1 and ParseDiskOutput2, and adding in procedure }
35 { ParseDirOutput2. }
36 { }
37 { Revision 84/11/29 15:00:00 Nelson Kanemoto }
38 { Wildcards are working for the store command, doing simple testing }
39 { }
40 { Revision 84/10/29 15:00:00 Nelson Kanemoto }
41 { Moved the storing part of ProcessStore to StoreFile to make way }
42 { for handling wildcards. Compiled and executed new version, but }
43 { didn't test it on storing files. }
44 { }
45 { Installation 84/10/29 14:40:00 Nelson Kanemoto }
46 { Updated ANSIMT.DOC, ANSIMT.HLP, and ANSIMT.EXE then installed them }
47 { to their proper locations (DOC:, HLP:, PS:<UHCCSYS-SUBSYS>). }
48 { }
49 { Revision 84/10/25 13:45:00 Nelson Kanemoto }
50 { Fixed bug in procedure ParseDiskOutput2. If someone added tape }
51 { parameters to the tape file spec, it wouldn't return the intended }
52 { error message. That's fixed now. }
53 { }
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 1-1
54 { Revision 84/09/25 15:30:00 Nelson Kanemoto }
55 { Added in an option to turn warning messages off and on in the }
56 { default command. Also added a no option in the default command }
57 { instead of "no-". }
58 { }
59 { Revision 84/09/25 14:00:00 Nelson Kanemoto }
60 { Program now automatically sets the default data mode to industry }
61 { compatible and returns to original data mode when it exits }
62 { }
63 { Revision 84/09/24 14:30:00 Nelson Kanemoto }
64 { Got rid of ^A in ANSIMT heading. }
65 { }
66 { Installation 84/09/20 16:00:00 Nelson Kanemoto }
67 { Latest version installed in PS:<UHCCSYS-SUBSYS> }
68 { }
69 { Revision 84/09/20 14:00:00 Nelson Kanemoto }
70 { Added in procedure to print ANSIMT heading. }
71 { }
72 { Revision 84/09/19 15:00:00 Nelson Kanemoto }
73 { corrected directory command to handle files w/ incorrect record }
74 { lengths and modified /FULL directory listing for 'U' format tape }
75 { files. }
76 { }
77 program ANSIMT_TapeUtility;
78 include 'sys:pascmd.pas';
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1
sys:pascmd.pas
1 const {declarations to help using break masks}
2
3 {Standard Field break mask
4 all control chars, space through comma, dot, slash,
5 colon through question mark, atsign, open bracket through accent grave,
6 and close bracket through tilde}
7 fldb0=777777777760B;
8 fldb1=777754001760B;
9 fldb2=400000000760B;
10 fldb3=400000000760B;
11
12 {Keyword break set. Same as standard field for now}
13 keyb0=777777777760B;
14 keyb1=777754001760B;
15 keyb2=400000000760B;
16 keyb3=400000000760B;
17
18 {Username break set. Breaks on everything except dot and alphabetics.}
19 usrb0=777777777760B;
20 usrb1=747544001760B;
21 usrb2=400000000740B;
22 usrb3=400000000760B;
23
24 {Account mask currently the same as user mask}
25 actb0=777777777760B;
26 actb1=747544001760B;
27 actb2=400000000740B;
28 actb3=400000000760B;
29
30 {Filespec field - filespec punctuation characters are legal ( :, <, >, ., ;)}
31 filb0=777777777760B;
32 filb1=74544000120B;
33 filb2=400000000240B;
34 filb3=400000000760B;
35
36 {Read Device Name - like standard field, but allow dollarsign and underscore}
37 devb0=777777777760B;
38 devb1=757754001760B;
39 devb2=400000000740B;
40 devb3=400000000760B;
41
42 {Read To End Of Line - break on linefeed and carraige return}
43 eolb0=000220000000B;
44 eolb1=000000000000B;
45 eolb2=000000000000B;
46 eolb3=000000000000B;
47
48 type
49 bitset=set of 0..35;
50 t=array[0:100]of integer;
51 table=^t;
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-1
52 tadrec=packed record
53 year:0..777777B; month:0..777777B;
54 dayofmonth:0..777777B; dayofweek:0..777777B;
55 zoneused:boolean;
56 daylightsavings:boolean;
57 zoneinput:boolean;
58 julianday:boolean;
59 dum:0..377B;
60 zone:0..77B;
61 seconds:0..777777B
62 end;
63 cmmodes=(normal,rescan);
64 brkmsk=array [0..3] of integer;
65
66 procedure cmini(prompt:string);extern;
67 {Use this procedure first. It will issue the prompt, and set things
68 up for reparsing in case of errors. Beware that if an error occurs
69 in any of the other CM functions, control may be returned to the
70 statement after the CMINI. Effectively this is done with a non-local
71 GOTO. Thus the code between the CMINI and the end of the parse must
72 be designed so that it can be restarted. Also, you must not exit the
73 block in which the CMINI is issued until the entire parse is done.
74 Since control will be returned to the CMINI in case of an error, it
75 would cause serious troubles if that block was no longer active. }
76
77 procedure cminir(prompt:string);extern;
78 {Special version of CMINI to be used when you want to read a rescanned
79 command from the EXEC. If this is done in a loop, the second time
80 it is done, the program exits.}
81
82 procedure cmfni(prompt: string; flag:integer); extern;
83 procedure cmfnir(prompt: string; flag:integer); extern;
84 {Special versions of CMINI and CMINIR. The left half of FLAG is set in
85 the .CMFLG word of the COMND JSYS state block. This is needed when
86 you want to set CM%RAI, CM%XIF, or CM%WKF}
87
88 function cmmode:cmmodes;extern;
89 {Says what "mode" we are running in. At the moment normal or rescan.
90 Rescan means that a CMINIR succeeded in finding valid rescanned data.}
91
92 procedure cmrscn; extern;
93 {Clears the RSCANF flag saying whether a RSCAN was done by CMINIR so
94 the next time CMINIR is called it will try for a rescaned command
95 again. The old value of RSCANF is returned. }
96
97 {The following two procedures are used in making up tables of commands
98 and switches. Note that tables and their contents are stored in the
99 heap. So you can use MARK and RELEASE to release them.}
100 function tbmak(size:integer):table;extern;
101 {Issue this one first. It allocates space for a table with the
102 specified number of entries. It returns a table pointer,
103 which is used for the other functions that operate on tables.}
104 procedure tbadd(t:table;value:integer;key:string;bits:integer);extern;
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-2
105 {Issue this once for each entry to go in the table.
106 T - the value return by the call to TBMAK that allocated the table.
107 VALUE - This is the value that will be returned when this entry
108 in the table is found.
109 KEY - This string is the name of the table entry.
110 BITS - as documented in the JSYS manual. Normally zero.
111 For example, one entry in a table of terminal types might be
112 tbadd( termtable, 6, 'I400', 0)
113 This entry will be matched by the string 'I400' (or any unique
114 abbreviation), and will return the value 6, presumably the internal
115 code for the I400 terminal.}
116 {WARNING: You must issue these in reverse alphabetical order, i.e.
117 the last entry in the table must be done first. This may be a
118 monitor bug.}
119
120 {The following procedures are used to parse individual fields in a command.
121 They should be issued in the same order that the user is expected to
122 type the fields.}
123
124 function cmkey(t:table):integer;extern;
125 {Expects the user to type one of the keywords in the table. It returns
126 the value that was specified by TBADD when the keyword was put in the
127 table. E.g. if the user typed I400, this would return 6 if the
128 table had the entry shown above.}
129
130 function cmswi(t:table):integer;extern;
131 {Similar to cmkey, except the table is of switches. The slash should
132 not be part of the name in the table.
133
134 If the user ended the switch with a colon (i.e. you can
135 expect a value after the switch), the negative of the value
136 normally returned will be returned.}
137
138 procedure cmifi(var f:file);extern;
139 {Expects the user to type an input file name. The argument should
140 be a Pascal file. That file will be preset to use the file specified.
141 E.g. if you say CMIFI(INPUT), you can then use RESET(INPUT) and INPUT
142 will be open on the file that the user specified. This function
143 actually gets a jfn for the file specified by the user. That jfn is
144 then stored in the file's file control block.}
145
146 procedure cmofi(var f:file);extern;
147 {Expects an output file name.}
148
149 procedure cmfil(var f:file);extern;
150 {Expects a general file spec. You must set up an extended gtjfn
151 block appropriately to read the file spec. This is done with
152 the gjxxx procedures below. At least gjgen must be used.}
153
154 function cmnum:integer; extern;
155 {Get a decimal number.}
156
157 function cmnum8:integer; extern;
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-3
158 {Get an octal number.}
159
160 function cmnux:integer; extern;
161 {Get a decimal number, ends with any non-numeric}
162
163 function cmnux8:integer; extern;
164 {Get an octal number, ends with any non-numeric}
165
166 function cmflt:real; extern;
167 {Get a real number}
168
169 procedure cmnoi(stuff:string);extern;
170 {Puts out a noise word if the user types altmode. Note that the
171 parentheses are not part of the noise word.}
172
173 procedure cmcfm; extern;
174 {Expects the user to type a carriage return. This would usually be
175 the last call made for parsing a command.}
176
177 procedure cmcma; extern;
178 {Expects the user to type a comma. If this is for an optional
179 field, you should set CMAUTO(false) first, to prevent an error
180 trap if there isn't one.}
181
182 procedure cmtok(stuff:string);extern;
183 {Expects the user to type that particular thing. See cmcma.}
184
185 procedure cmctok(c:char);extern;
186 {like CMTOK, but takes a single character instead of a string.}
187
188 function cmdir:integer; extern;
189 {Expects a directory name: returns the 36-bit dir. number. To
190 see the text, use CMATOM.}
191
192 function cmdirw:integer; extern;
193 {as above, but allows wildcards}
194
195 function cmusr:integer; extern;
196 {Expects a user name: returns a 36-bit user number.(CMATOM for text)}
197
198 function cmdev:integer; extern;
199 {Expects a device name: returns a device designator (CMATOM for text)}
200
201 {The following functions parse date and/or time. We have the following
202 method:
203 TAD - both date and time null - returns internal form
204 T - time only N - puts unconverted form into a record
205 D - date only}
206
207 function cmtad:integer; extern;
208 function cmt:integer; extern;
209 function cmd:integer; extern;
210 procedure cmtadn(var r:tadrec); extern;
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-4
211 procedure cmtn(var r:tadrec); extern;
212 procedure cmdn(var r:tadrec); extern;
213
214 {The following procedures all return strings where you specify, and
215 a count indicating how many characters were actually seen. Any
216 extra characters in the destination array are filled with blanks.
217 If there is not enough space, an error message is given and a
218 reparse triggered.}
219
220 function cmatom(var s:string):integer; extern;
221 {This returns the contents of the "atom buffer". It is useful when
222 you want to see what the user actually typed for the last field. It
223 not cause any extra parsing, the data comes from the last field parsed.}
224
225 function cmtext(var s:string):integer; extern;
226 {This returns the contents of the "text" buffer. This will have what
227 has been parsed. Useful for writting you own error handlers.}
228
229 function cmfld(var s:string):integer; extern;
230 {Field delimited by first non-alphanumeric}
231
232 function cmtxt(var s:string):integer; extern;
233 {To next end of line}
234
235 function cmqst(var s:string):integer; extern;
236 {String in double quotes. Quotes not returned.}
237
238 function cmuqs(var s: string; break_mask: brkmsk; var b: char):integer;
239 extern;
240 {Unquoted string. NOTE: Do NOT use CMBRK to set the break mask for
241 this function. Use the second argument provided for that task.
242 The third argument has the break character that was used returned in
243 it. This doesn't seem to work for some special characters (like escape)
244 also you might want to set the CM%WKF bit in the comnd state block to
245 cause a wakeup on each field while parsing. See CMFIN procedure for
246 how to do that.}
247
248 function cmact(var s:string):integer; extern;
249 {Account string. Not verified for legality}
250
251 function cmnod(var s:string):integer; extern;
252 {network node name. Not verified for legality}
253
254 {The following procedures are used to set up the extended gtjfn block
255 for cmfil. They must be given before the cmfil call. gjgen must
256 always be used, and must be the first one of these to be called, as
257 it clears the rest of the block. These procedures simply set the
258 corresponding words in the gtjfn block, so see the jsys manual for
259 details.}
260
261 procedure gjgen(flags_and_generation:integer);extern;
262
263 procedure gjdev(default_device:string);extern;
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-5
264
265 procedure gjdir(default_directory:string);extern;
266
267 procedure gjnam(default_name:string);extern;
268
269 procedure gjext(default_extension:string);extern;
270
271 procedure gjpro(default_protectin:string);extern;
272
273 procedure gjact(default_account:string);extern;
274
275 procedure gjjfn(try_to_use_this_jfn:integer);extern;
276
277 procedure gjf2(more_flags:bitset);extern;
278
279 {The following procedures are only needed for more complex parsers.
280 They allow one to turn off various of the features that are normally
281 supplied by default.}
282
283 procedure cmauto(useauto:Boolean);extern;
284 {Turn on or off automatic error processing. It is turned on by default.
285
286 When automatic error processing is in effect, if the user does not
287 type what is requested, an error message is issued and the prompt is
288 reissued. At that point he can either type a new command, or type
289 ^H to have the old command repeated up to the point of the error.
290 Thus in the normal mode, the programmer does not need to worry about
291 errors. Reparsing is done until the user types something valid.
292
293 When automatic error processing has been turned off, no automatic
294 reparsing is done for errors. Instead the procedure that was trying
295 to read the field returns with a null value (if any). The user is
296 expected to check for errors with cmerr. This is useful in the
297 case where there are several valid responses. For example suppose
298 either a keyword or a file is valid. Then you could do
299 cmauto(false); % turn off error handling \
300 cmifi(input);
301 if cmerr % wasn't a valid file \
302 then key := cmkey(keytable);
303 In general one should probably turn cmauto back on before trying
304 the last alternative, so that a reparse is done if it isn't valid.
305
306 Note that even with cmauto false, some automatic reparses are still
307 done if the user backspaces into a previously parsed fields. cmauto
308 only controls what happens on a genuine error.
309
310 cmini reinitializes cmauto to true.}
311
312 function cmerr:Boolean; extern;
313 {Returns true if the most recent parse call got an error.}
314
315 procedure cmagain; extern;
316 {Abort the current parse, reissue the prompt and try again. If
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-6
317 cmauto is in effect, this is done automatically whenever there is
318 an error. Note that cmagain does not print an error message.
319 It is assumed that if you want the normal error message, you will
320 turn on cmauto and let everything happen automatically.}
321
322 procedure cmuerr(s:string); extern;
323 {Print ?, clear the input buffer, print the string supplied,
324 and call cmagain. This is equivalent to the usual error
325 processing, but with a user-supplied error message.}
326
327 procedure cmerrmsg; extern;
328 {This prints the official error message from the last failure.
329 This followed by cmagain is equivalent to the usual error processing.}
330
331 function cmeof(trap: boolean):boolean; extern;
332 {This function is used to trap end of file conditions detected by the
333 COMND jsys. If TRAP is TRUE then the next eof will cause a reparse
334 (instead of an illegal instruction trap) and cmeof will return true
335 to indicate that the eof has happened. Use of this is as followes:
336 CMINI('prompt');
337 IF CMEOF(TRUE) THEN eof_code;
338 normal parsing stuff
339
340 NOTE: Because a reparse is done when the error is seen, you should
341 place the call to CMEOF just after your call to CMINI (or CMINIR)
342 and before ANY CALLES TO OTHER PROCEDURES IN THIS PACKAGE. If you
343 fail to do this the program will go into an infinite loop. }
344
345 function cmioj(newjfns: integer):integer; extern;
346 {This function sets .CMIOJ of the COMND state block to NEWJFNS and
347 returns the old value of that word. This is useful for "pushing"
348 the current JFNs.}
349
350 procedure cmhlp(helptext:string); extern;
351 {Used to supply your own help message when the user types ?. The
352 text given will be used for the next field parsed. To supply a
353 message taking up more than one line, just call cmhlp several
354 times. Each call will add a line to the message. (Thus cmhlp
355 is vaguely like writeln.) Note that the help message stays in
356 effect only for the next field parsed.}
357
358 procedure cmdef(default:string); extern;
359 {Used to supply a default value for the next field parsed. This
360 default stays in effect only for the next field.}
361
362 function cmstat:integer; extern;
363 {Returns the address of the COMND state block. Don't write into
364 unless you really know what you're doing.}
365
366 procedure cmbrk(break_mask: brkmsk); extern;
367 {Used to supply a break mask for use in parsing the next field.}
368
369 procedure brini(var break_mask: brkmsk; w0, w1, w2, w3: integer); extern;
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-7
370 {Used to copy w0 through w3 into BREAK_MASK. Hint use this an the
371 predefined CONSTants (at the beginning of this file) to set up break
372 masks. For example to be able to parse keywords with ^ in them:
373
374 brini(break,fldb0,fldb1,fldb2,flbd3);
375 brmsk(break,'^','');
376 ...
377 cmbrk(break);
378 which := cmkey(keyword_table);
379 }
380
381 procedure brmsk(var break_mask: brkmsk; allow, disallow: string); extern;
382 {Use to make a break mask with the characters, ALLOW, allowed and
383 DISALLOW, disallowed.}
384
385 {In some cases you may want to allow a choice of several alternatives.
386 To do this, issue CMMULT, to go into "multiple choice mode". Once
387 in this mode, issue CMxxx calls as usual. Instead of being done
388 immediately, these calls store away specifications of the legal
389 alternatives. For those that are functions, the values returned are
390 garbage. Once you have specified all the alternatives, call
391 CMDO. This returns an integer, 1..the number of alternatives,
392 telling you which (if any) succeeded, 0 if none did.
393 For alternatives that return values, you can then do
394 CMINT to get the returned value if it is an integer, or CMREAL if it
395 is real. Alternatives that return values in variables passed by
396 reference will do so, using the variable passed when the original
397 CMxxx was called. (Needless to say, that variable has better still
398 be accessible.)}
399
400 procedure cmmult; extern;
401 {Enter multiple choice mode. All CMxxx procedures until the next
402 CMDO are interpreted as specifications, rather than done immediately.}
403
404 function cmdo:integer; extern;
405 {Do a COMND jsys, specifying the alternatives stored up since the
406 last CMMULT. Returns a code indicating which succeeded, or 0 if
407 none did. Since the return value is used to indicate which
408 alternative was found, there is a possible question: how do we
409 get the returned value, if there is one (i.e. if the alternative
410 found is a Pascal function that returns some value)? The answer
411 to this is that the value returned is stored away internally
412 and is available by CMINT or CMREAL, depending upon its type.
413 Note that files and strings are returned through variables
414 passed by reference. They do not need this mechanism, since
415 that will be set automatically. (What happens is that the
416 addresses of all reference variables are stored away when the
417 alternative is first set up, and the appropriate one is set when
418 we find out which alternative is actually there.)}
419
420 function cmint:integer; extern;
421 {Return a value from the last CMDO, if the alternative that succeeded
422 was an integer}
PASCAL %14(331) 19-Dec-85 ANSIMT ****Included File**** PAGE 1-8
423
424 function cmreal:real; extern
425 {Return a value from the last CMDO, if the alternative that succeeded
426 was a real}
427
428
429 .
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 1-2
Main file continued
78
79 const
80 DEFBLKFAC = '1 ';
81 DEFRECLEN = '80';
82 DEFTABNO = '8 ';
83 MAXFNAME = 39;
84 MAXBLKLEN = 32760; {IBM max}
85 MAXRECLEN = 2048; {ANSI standard}
86 MAXSTR = 80;
87 MINRECLEN = 18; {ANSI standard}
88
89 {pascmd parsing}
90 {-CmdTable}
91 DIR = 1;
92 DEF = 2;
93 EOT = 3;
94 XIT = 4;
95 SKIP = 5;
96 STORE = 6;
97 RESTORE = 7;
98 REWIND = 8;
99 TAPE = 9;
100 HELP = 11;
101 LASTCMD = 11;
102 {-Sw1Table}
103 S1BLOCK = 1;
104 S1NOPAD = 2;
105 S1RECLN = 3;
106 S1TABEV = 4;
107 LASTSW1 = 4;
108 {-Sw2Table}
109 S2NOSTR = 5;
110 S2STRIP = 6;
111 LASTSW2 = 2;
112 {-Sw3Table, switches for directory command}
113 S3FULL = 1;
114 S3SHORT = 2;
115 LASTSW3 = 2;
116 {-DefTable, uses above switches}
117 DFWARN = 1;
118 DFTABEV = 2;
119 DFSTRIP = 3;
120 DFRECLN = 4;
121 DFNOSWI = 5;
122 DFBLOCK = 6;
123 LASTDEF = 6;
124 LASTNO = 3; {no options}
125
126 {JSYS monitor calls}
127 GETER = 12B; {returns most recent error condition}
128 OPENF = 21B;
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 1-3
129 CLOSEF = 22B;
130 JFNS = 30B;
131 MTOPR = 77B;
132
133 {ASCII in decimal}
134 NULL = 0;
135 TAB = 9;
136 LF = 10; {linefeed}
137 CR = 13; {carriage return}
138 BLANK = 32;
139
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 2
1
2 type
3 DevicesType = (DiskDev, TapeDev, TTYDev, ErrDev);
4 DesigType = (JFNDes, DevDes);
5 DirectoryType = (FullDir, ShortDir);
6 WordSetType = set of 0..35; {represents a 36bit word}
7 DateStrType = packed array [1..9] of char;
8 StrType = packed array [1..MAXSTR] of char;
9 FNameType = packed array [1..MAXFNAME] of char;
10
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 3
1
2 var
3 device : integer;
4 command : integer;
5 FilesToSkip : integer;
6 OriginalDataMode : integer;
7 DefaultRecLen, DefaultBlkFac, DefaultTabNo : integer;
8 GlobalRecLen, GlobalBlkFac, GlobalTabNo : integer;
9 HoldRecLen, HoldBlkFac, HoldTabNo : integer;
10 ThatsIt : boolean;
11 GlobalPadTabs, DefaultPadTabs, HoldPadTabs : boolean;
12 GlobalWarning, DefaultWarning, HoldWarning : boolean;
13 GlobalStripBlanks, DefaultStripBlanks, HoldStripBlanks : boolean;
14 GlobalDirectory, DefaultDirectory, HoldDirectory : DirectoryType;
15 GlobalTapeFile, GlobalTape, HoldTape : FNameType;
16 GlobalDiskFile, GlobalDirStr : StrType;
17 CmdTable, DefTable, NoTable, Sw1Table, Sw2Table, Sw3Table: table;
18
19 function curjfn(var f : file) : integer; extern;
20
21 function erstat(var f : file) : integer; extern;
22
23 procedure analysis(var f : file); extern;
24
25 procedure clreof(var f : file); extern;
26
27 procedure quit; extern;
28
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 4
1
2 { StrEnd -- marks the end of string w/ a null character. If end }
3 { position, SEnd, is out of bounds then the end is not marked. }
4 procedure StrEnd(var s : packed array [i..j:integer] of char;SEnd : integer);
5 var
6 pos : integer;
7 begin
8 pos := SEnd - (i - 1); {actual index in string}
9 if (pos >= i) and (pos <= j) then
10 s[pos] := chr(NULL);
11 end; {of procedure StrEnd}
12
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 5
1
2 { StrPos -- returns the position of a character in a string. 0 is }
3 { returned if the character is not found. }
4 function StrPos(var s : packed array [i..j:integer] of char;c : char) : integer;
5 var
6 pos : integer;
7 found : boolean;
8 begin
9 pos := i - 1;
10 StrPos := 0; found := false;
11 while (pos < j) and not found do begin
12 pos := pos + 1;
13 if (s[pos] = c) then begin
14 StrPos := pos;
15 found := true;
16 end; {of if}
17 end; {of while}
18 end; {of function StrPos}
19
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 6
1
2 { StrLen -- returns the length of string s which is marked by the }
3 { null character }
4 function StrLen(var s : packed array [i..j:integer] of char) : integer;
5 var
6 pos : integer;
7 begin
8 pos := StrPos(s,chr(NULL));
9 if (pos <> 0) then
10 StrLen := pos - 1
11 else
12 StrLen := j - (i - 1); {length of array, s}
13 end; {of function StrLen}
14
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 7
1
2 { itoc -- converts integer n to char string in s[i]... }
3 function itoc(n : integer; var s : StrType ; i : integer) : integer;
4 begin
5 if (n < 0) then begin
6 s[i] := '-';
7 itoc := itoc(-n,s,i+1);
8 end {of if}
9 else begin
10 if (n >= 10) then
11 i := itoc(n div 10,s,i);
12 s[i] := chr(n mod 10 + ord('0'));
13 StrEnd(s,i+1);
14 itoc := i + 1;
15 end; {else}
16 end; {of function itoc}
17
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 8
1
2 { ctoi -- convert char string at s[i] to integer }
3 function ctoi(s : packed array [SMin..SMax : integer] of char;
4 i : integer) : integer;
5 var
6 n, sign : integer;
7 begin
8 while (s[i] = ' ') or (s[i] = chr(TAB)) do
9 i := i + 1;
10 if (s[i] = '-') then {minus sign}
11 sign := -1
12 else
13 sign := 1;
14 if (s[i] = chr(ord('+'))) or (s[i] = chr(ord('-'))) then
15 i := i + 1;
16 n := 0;
17 while (i <= SMax) do
18 if (s[i] in ['0'..'9']) then begin
19 n := 10 * n + (ord(s[i]) - ord('0'));
20 i := i + 1;
21 end {of if}
22 else
23 i := SMax + 1; {force out}
24 ctoi := sign * n;
25 end; {of function ctoi}
26
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 9
1
2 { scopy -- copy string at src[i] to dest[j] }
3 procedure scopy( src : packed array [SMin..SMax : integer] of char;
4 i : integer;
5 var dest : packed array [DMin..DMax : integer] of char;
6 j : integer);
7 begin
8 while (i <= SMax) and (j <= DMax) do
9 if (src[i] <> chr(NULL)) then begin
10 dest[j] := src[i];
11 i := i + 1;
12 j := j + 1;
13 end
14 else {force it to stop if hits the end of string}
15 i := SMax + 1; {end the while loop}
16
17 if (j <= DMax) then
18 StrEnd(dest,j);
19 end; {of procedure scopy}
20
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 10
1
2 { InToStrDate -- converts a date i in internal format to a string }
3 { of 9 chars in DD-Mmm-YY format }
4 procedure InToStrDate(i : integer;var str : DateStrType);
5 const
6 ODTIM = 220B;
7 begin
8 jsys(ODTIM;str,i,000400000000B);
9 end; {of procedure InToStrDate}
10
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 11
1
2 { TabPos -- return true if col is a tab stop }
3 function TabPos(col : integer) : boolean;
4 begin
5 if (col > MAXRECLEN) then
6 TabPos := true
7 else
8 TabPos := (col mod GlobalTabNo = 1);
9 end; {of function TabPos}
10
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 12
1
2 { ErrorMess -- prints the last error in the buffer than goes back }
3 { for a reparse }
4 procedure ErrorMess;
5 begin
6 cmerrmsg; {print official error message}
7 cmagain; {reissue prompt}
8 end; {of procedure ErrorMess}
9
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 13
1
2 { WarnMess -- prints the given string as an official warning message }
3 { (beginning w/ an '%') }
4 procedure WarnMess(s : packed array [i..j : integer] of char);
5 begin
6 if DefaultWarning then
7 writeln(tty,'%',s:StrLen(s));
8 end; {of procedure WarnMess}
9
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 14
1
2 { ClearDataError -- if the device has a data error it is cleared }
3 procedure ClearDataError(var f : file);
4 const
5 GDSTS = 145B; {device status}
6 SDSTS = 146B; {sets device status}
7 INCORRECT_RECLN = 23;
8 var
9 StatusBits, DummyBits : WordSetType;
10 i : integer;
11 begin
12 jsys(GDSTS;0:f;DummyBits,StatusBits);
13 if (INCORRECT_RECLN in StatusBits) then begin {data error}
14 StatusBits := StatusBits - [INCORRECT_RECLN];
15 jsys(SDSTS;0:f,StatusBits);
16 end; {of if}
17 end; {of procedure ClearDataError}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 15
1
2 { FileOpen -- returns true if file is open }
3 function FileOpen(var f : file) : boolean;
4 const
5 GTSTS = 24B; {file status}
6 FILE_IS_OPEN = 0;
7 var
8 StatusBits, DummyBits : WordSetType;
9 begin
10 jsys(GTSTS;0:f;DummyBits,StatusBits);
11 if (FILE_IS_OPEN in StatusBits) then
12 FileOpen := true
13 else
14 FileOpen := false;
15 end; {of function FileOpen}
16
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 16
1
2 function OpenInputFile(dev : DevicesType) : boolean;
3 var
4 FileSpec : StrType;
5 begin
6 if (dev = DiskDev) then
7 reset(input,'','/e/o')
8 else if (dev = TTYDev) then begin
9 jsys(JFNS;FileSpec,0:input,0);
10 reset(input,'','/e/o/i');
11 end; {of else if}
12 if (erstat(input) <> 0) then begin
13 analysis(input);
14 if (dev = TapeDev) then
15 if FileOpen(input) then
16 ClearDataError(input);
17 if FileOpen(input) then
18 close(input);
19 OpenInputFile := false;
20 end {of if}
21 else
22 OpenInputFile := true;
23 end; {of function OpenInputFile}
24
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 17
1
2 function OpenInputTape : boolean;
3 const
4 DATAERR = 600221B;
5 BIGREC = 601240B;
6 var
7 message : StrType;
8 begin
9 reset(input,'','/d/o/m:7');
10 if (erstat(input) <> 0) then begin
11 if (erstat(input) = DATAERR) or (erstat(input) = BIGREC) then begin
12 jsys(JFNs;message,0:input,0);
13 scopy(' not able to be restored',1,message,StrLen(message)+1);
14 WarnMess(message);
15 if FileOpen(input) then
16 ClearDataError(input);
17 if FileOpen(input) then {if it is still open}
18 close(input);
19 OpenInputTape := False;
20 end {of if}
21 else begin
22 analysis(input);
23 if FileOpen(input) then
24 ClearDataError(input);
25 if FileOpen(input) then {if it is still open}
26 close(input);
27 OpenInputTape := False;
28 cmagain;
29 end {of else}
30 end {of if}
31 else
32 OpenInputTape := True;
33 end; {of procedure OpenInputTape}
34
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 18
1
2 function OpenOutputDisk : boolean;
3 begin
4 rewrite(output,GlobalDiskFile,'/o');
5 if (erstat(output) <> 0) then begin
6 analysis(output);
7 OpenOutputDisk := false;
8 end {of if}
9 else
10 OpenOutputDisk := true;
11 end; {of function OpenOutputDisk}
12
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 19
1
2 function OpenOutputTape(var TapeFile : FNameType) : boolean;
3 const
4 TFORM = ';FOR:F'; {tape format, always fixed}
5 TRECL = ';REC:'; {tape rec length}
6 TBLKS = ';BLO:'; {tape block size}
7 TOPTIONS = '/B:8/O';
8 var
9 i : integer;
10 FileSpec : StrType;
11 begin
12 scopy(TapeFile,1,FileSpec,1);
13 scopy(TFORM,1,FileSpec,StrLen(FileSpec)+1);
14 scopy(TRECL,1,FileSpec,StrLen(FileSpec)+1);
15 i := itoc(GlobalRecLen,FileSpec,StrLen(FileSpec)+1);
16 scopy(TBLKS,1,FileSpec,StrLen(FileSpec)+1);
17 i := itoc(GlobalBlkFac*GlobalRecLen,FileSpec,StrLen(FileSpec)+1);
18 rewrite(output,FileSpec,TOPTIONS);
19 if (erstat(output) <> 0) then begin
20 analysis(output);
21 write(tty,' - "',FileSpec:StrLen(FileSpec),'"');
22 OpenOutputTape := false;
23 end {of if}
24 else
25 OpenOutputTape := true;
26 end; {of function OpenOutputTape}
27
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 20
1
2 { KindOfDevice -- returns the what kind of device is associated w/ }
3 { the file. }
4 function KindOfDevice(des : integer;TypeOfCall : DesigType) : DevicesType;
5 const
6 DVCHR = 117B;
7 var
8 ac1, ac2, TypeOfDev : WordSetType;
9 begin
10 case TypeOfCall of
11 JFNDes : jsys(DVCHR;0:des;ac1,ac2); {call using file JFN}
12 DevDes : jsys(DVCHR;des;ac1,ac2); {call using dev designator}
13 end; {of case des}
14 TypeOfDev := ac2 and [9..17]; {mask the dev type bits}
15 if (TypeOfDev = []) then {disk file}
16 KindOfDevice := DiskDev
17 else if (TypeOfDev = [14,16]) then {tty}
18 KindOfDevice := TTYDev
19 else if (TypeOfDev = [16]) then {tape file}
20 KindOfDevice := TapeDev
21 else
22 KindOfDevice := ErrDev;
23 end; {of function KindOfDevice}
24
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 21
1
2 { space -- spaces n number of blanks to the terminal. }
3 procedure space(n : integer);
4 begin
5 for n := n downto 1 do
6 write(tty,' ');
7 end; {of procedure space}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 22
1
2 { GarbageErr -- outputs to dev tty: garbage that was entered as }
3 { part of the command. }
4 procedure GarbageErr(mess : packed array [i..j:integer] of char;
5 garb : packed array [k..l:integer] of char);
6 var
7 MessLen : integer;
8 begin
9 writeln(tty);
10 write(tty,'? ',mess:StrLen(mess));
11 write(tty,' - ');
12 write(tty,garb:StrLen(garb));
13 writeln(tty);
14 cmagain;
15 end; {of procedure GarbageErr}
16
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 23
1
2 { GetJobDataMode -- uses jsys GETJI and returns the default magtape }
3 { data mode of the current job }
4 function GetJobDataMode : integer;
5 const
6 GETJI = 507B;
7 var
8 return : integer;
9 p : ^integer;
10 begin
11 new(p);
12 jsys(GETJI,2,return;-1,-1:p,14B);
13 if (return = 1) then
14 ErrorMess
15 else
16 GetJobDataMode := p^;
17 end; {of function GetJobDataMode}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 24
1
2 { SetJobDataMode -- sets data mode of the current job }
3 procedure SetJobDataMode(DataMode : integer);
4 const
5 SETJB = 541B; {sets job para for the specified job}
6 SJDM = 2B; {func of SETJB to set def mt data mode}
7 CURRENT_JOB = -1;
8 begin
9 jsys(SETJB;CURRENT_JOB,SJDM,DataMode);
10 end; {of procedure SetJobDataMode}
11
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 25
1
2 { DirHeading -- prints the heading for the tape directory }
3 procedure DirHeading;
4 begin
5 {1st line}
6 space(33);
7 write(tty,'RECORD');
8 space(1);
9 write(tty,'BLOCK');
10 space(3);
11 if (GlobalDirectory = FullDir) then begin
12 space(1);
13 write(tty,'# OF');
14 space(2);
15 write(tty,'EST.');
16 space(2);
17 end; {of if}
18 space(1);
19 write(tty,'CREATE');
20 space(4);
21 write(tty,'EXPIRE');
22 writeln(tty);
23 {2nd line}
24 write(tty,'SEQ#');
25 space(6);
26 write(tty,'FILE NAME');
27 space(5);
28 write(tty,'VOLID');
29 space(2);
30 write(tty,'F');
31 space(1);
32 write(tty,'LENGTH');
33 space(1);
34 write(tty,'FACTOR');
35 space(2);
36 if (GlobalDirectory = FullDir) then begin
37 space(1);
38 write(tty,'RECS.');
39 space(1);
40 write(tty,'PAGES');
41 space(1);
42 end; {of if}
43 space(2);
44 write(tty,'DATE');
45 space(6);
46 write(tty,'DATE');
47 writeln(tty);
48 {3rd line}
49 writeln(tty);
50 end; {of procedure DirHeading}
51
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 26
1
2 { GetDeviceJFN -- gets the jfn for the defined tape divice }
3 procedure GetDeviceJFN;
4 const
5 SGTJFN = 20B; {short form GTJFN}
6 var
7 DevStore, return : integer;
8 DevStr : FNameType;
9 begin
10 DevStr := GlobalTape;
11 DevStr[StrLen(DevStr)+1] := ':'; {put a ':' at the end of string}
12 StrEnd(DevStr,StrPos(DevStr,':')+1);
13 jsys(SGTJFN, 3, return;100001b:0, DevStr;DevStore);
14 if (return = 1) then
15 ErrorMess;
16 device := DevStore;
17 end; {of procedure GetDeviceJFN}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 27
1
2 { TapeInfo -- calls MTOPR to find information about the current }
3 { tape device }
4 function TapeInfo(InfoNo : integer) : integer;
5 const
6 MOINF = 25B;
7 MAXINFO = 15B;
8 type
9 ArgBlkType = packed array [0..MAXINFO] of integer;
10 var
11 ArgPtr : ^ArgBlkType;
12 begin
13 new(ArgPtr);
14 ArgPtr^[0] := MAXINFO;
15 GetDeviceJFN;
16 jsys(MTOPR;0:device, MOINF, ArgPtr);
17 TapeInfo := ArgPtr^[InfoNo];
18 end; {of function TapeInfo}
19
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 28
1
2 { TapeStatus -- returns status bits for user io }
3 procedure TapeStatus(var accum2 : WordSetType);
4 const
5 GDSTS = 145B;
6 var
7 accum1, return : integer;
8 begin
9 GetDeviceJFN;
10 jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
11 if (return = 1) then
12 ErrorMess;
13 jsys(GDSTS;0:device;accum1, accum2);
14 jsys(CLOSEF, 2, return;001000:device);
15 if (return = 1) then
16 ErrorMess;
17 end; {of procedure TapeStatus}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 29
1
2 { BeginningOfTape -- returns true if tape is at bot }
3 function BeginningOfTape : boolean;
4 const
5 BOTBIT = 24;
6 var
7 StatBits : WordSetType;
8 begin
9 TapeStatus(StatBits);
10 if (BOTBIT in StatBits) then
11 BeginningOfTape := true
12 else
13 BeginningOfTape := false;
14 end; {of function BeginningOfTape}
15
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 30
1
2 { TapeFileInfo -- prints out tape file info. If the SeqNo passed }
3 { is negative then the no. of records and the estimated pages are }
4 { suppressed in the /FULL switch }
5 procedure TapeFileInfo(SeqNo : integer);
6 const
7 MORLI = 50B;
8 ARGS = 15B;
9 UNDEFINED = 'U'; {undefined record format}
10 type
11 BitsAndPtrType = record
12 case boolean of
13 true : (ptr : ^FNameType);
14 false: (bits : WordSetType)
15 end;
16 ArgBlkType = record
17 ArgWords : integer;
18 TypeOfLabel : integer;
19 p1 : ^FNameType;
20 p2 : ^FNameType;
21 TapeFormat : integer;
22 RecLen : integer;
23 BlkLen : integer;
24 CreateDate : integer;
25 ExpireDate : integer;
26 p3 : ^FNameType;
27 generation : integer;
28 version : integer;
29 ModeVal : integer;
30 end; {of record}
31 var
32 i : integer;
33 BadRead : boolean; {record is unreadable}
34 VolName, OwnName, FilName : BitsAndPtrType;
35 DateStr : DateStrType;
36 ArgBlkPtr : ^ArgBlkType;
37
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 31
1
2 { FullInformation -- prints the record length and est. pages info }
3 { for tape files }
4 procedure FullInformation(RecLen : integer);
5 var
6 nl, EstPages : integer;
7 begin
8 nl := 0;
9 while not eof do begin {count # of lines}
10 readln;
11 nl := nl + 1;
12 end; {of while}
13 {calculate estimated pages}
14 if ((RecLen * nl) mod (512 * 5) = 0) then
15 EstPages := (RecLen * nl) div (512 * 5)
16 else
17 EstPages := ((RecLen * nl) div (512 * 5)) + 1; {add a page}
18 write(tty,nl:6);
19 space(1);
20 write(tty,EstPages:5);
21 space(1);
22 end; {of procedure FullInformation}
23
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 32
1
2 begin
3 if (SeqNo < 0) then begin
4 BadRead := true;
5 SeqNo := -SeqNo; {set back to positive}
6 end
7 else
8 BadRead := false;
9 new(ArgBlkPtr);
10 with ArgBlkPtr^ do begin
11 ArgWords := ARGS;
12 new(VolName.ptr);
13 VolName.bits := VolName.bits or [0..17];
14 p1 := VolName.ptr;
15 new(OwnName.ptr);
16 OwnName.bits := OwnName.bits or [0..17];
17 p2 := OwnName.ptr;
18 new(FilName.ptr);
19 FilName.bits := FilName.bits or [0..17];
20 p3 := FilName.ptr;
21 jsys(MTOPR;0:input,MORLI,ArgBlkPtr);
22 {formatted output to tty}
23 write(tty,SeqNo:4);
24 space(2);
25 write(tty,FilName.ptr^:StrLen(FilName.ptr^));
26 space(17-StrLen(FilName.ptr^));
27 space(1);
28 write(tty,VolName.ptr^:StrLen(VolName.ptr^));
29 space(6-StrLen(VolName.ptr^));
30 space(1);
31 write(tty,chr(TapeFormat):1);
32 space(2);
33 if (chr(TapeFormat) = UNDEFINED) then begin
34 if (RecLen = 0) then {no such thing as rec len 0}
35 RecLen := 1;
36 write(tty,BlkLen:5); {actually prints as Rec Len}
37 space(2);
38 write(tty,RecLen:5);
39 end {of if}
40 else begin
41 write(tty,RecLen:5);
42 space(2);
43 write(tty,(BlkLen div RecLen):5);
44 end; {of else}
45 space(2);
46 if (GlobalDirectory = FullDir) then
47 if BadRead then {cannot read records}
48 write(tty,' -- -- ') {fill in info}
49 else
50 FullInformation(RecLen);
51 InToStrDate(CreateDate,DateStr);
52 write(tty,DateStr:9);
53 space(1);
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 32-1
54 if (ExpireDate = -1) then
55 write(tty,' Invalid ')
56 else begin
57 InToStrDate(ExpireDate,DateStr);
58 write(tty,DateStr:9);
59 end; {of else}
60 writeln(tty);
61 end; {of with}
62 {get rid of junk}
63 dispose(ArgBlkPtr);
64 dispose(VolName.ptr);
65 dispose(OwnName.ptr);
66 dispose(FilName.ptr);
67 end; {of procedure TapeFileInfo}
68
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 33
1
2 { TrapEOT -- returns true if defined device is at end of tape }
3 function TrapEOT : boolean;
4 const
5 LOGEOT = 602240B; {logical eot encountered}
6 type
7 IOrBType = record
8 case boolean of
9 true : (int : integer);
10 false: (bits : WordSetType)
11 end; {of record}
12 var
13 ac1, ac2 : integer;
14 Ac2Store : IOrBType;
15 begin
16 jsys(GETER;400000B;ac1,ac2);
17 with Ac2Store do begin
18 int := ac2;
19 bits := (bits and [18..35]); {clear 1st half}
20 if (int = LOGEOT) then
21 TrapEOT := true
22 else
23 TrapEOT := false;
24 end; {of with}
25 end; {of function TrapEOT}
26
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 34
1
2 { ForwardFile -- calls mtopr to skip forward 1 logical file }
3 procedure ForwardFile;
4 const
5 MOFWF = 16B;
6 var
7 return : integer;
8 begin
9 GetDeviceJFN;
10 jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
11 if (return = 1) then
12 ErrorMess;
13 jsys(MTOPR,-2,return;0:device, MOFWF);
14 if (return = 3) then begin
15 cmerrmsg; {print official error message}
16 jsys(CLOSEF, 2, return;001000:device);
17 if (return = 1) then
18 cmerrmsg;
19 cmagain;
20 end {of begin}
21 else begin
22 jsys(CLOSEF,2,return;001000:device);
23 if (return = 1) then
24 ErrorMess;
25 end; {of begin}
26 end; {of procedure ForwardFile}
27
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 35
1
2 { BackwardFile -- calls mtopr to skip backward 1 logical file }
3 procedure BackwardFile;
4 const
5 MOBKF = 17B;
6 var
7 return : integer;
8 begin
9 GetDeviceJFN;
10 jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
11 if (return = 1) then
12 ErrorMess;
13 jsys(MTOPR;0:device, MOBKF);
14 jsys(CLOSEF,2,return;001000:device);
15 if (return = 1) then
16 ErrorMess;
17 end; {of procedure BackwardFile}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 36
1
2 { RewindTape -- rewinds tape to bot }
3 procedure RewindTape;
4 const
5 MOREW = 1;
6 var
7 return : integer;
8 begin
9 GetDeviceJFN;
10 jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
11 if (return = 1) then
12 ErrorMess;
13 jsys(MTOPR;0:device, MOREW);
14 jsys(CLOSEF, 2, return;001000:device);
15 if (return = 1) then
16 ErrorMess;
17 end; {of procedure RewindTape}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 37
1
2 { CheckIfTapeAssigned -- check if user issued tape command to }
3 { define a tape device, if not reparse }
4 procedure CheckIfTapeAssigned;
5 begin
6 if (StrLen(GlobalTape) = 0) then
7 cmuerr('Tape device not defined, use TAPE command to define device')
8 end; {of CheckIfTapeAssigned}
9
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 38
1
2 { InitTables -- initializes pascmd tables to be used for parsing }
3 procedure InitTables;
4 begin
5 CmdTable := tbmak(LASTCMD);
6 tbadd(CmdTable,TAPE,'TAPE',0);
7 tbadd(CmdTable,REWIND,'REWIND',0);
8 tbadd(CmdTable,RESTORE,'RESTORE',0);
9 tbadd(CmdTable,STORE,'STORE',0);
10 tbadd(CmdTable,SKIP,'SKIP',0);
11 tbadd(CmdTable,HELP,'HELP',0);
12 tbadd(CmdTable,XIT,'EXIT',0);
13 tbadd(CmdTable,EOT,'EOT',0);
14 tbadd(CmdTable,DIR,'DIRECTORY',0);
15 tbadd(CmdTable,DEF,'DEFAULT',0);
16
17 Sw1Table := tbmak(LASTSW1);
18 tbadd(Sw1Table,S1BLOCK,'BLOCKING-FACTOR:',0);
19 tbadd(Sw1Table,S1NOPAD,'NO-PAD-TABS',0);
20 tbadd(Sw1Table,S1TABEV,'PAD-TABS:',0);
21 tbadd(Sw1Table,S1RECLN,'RECORD-LENGTH:',0);
22
23 Sw2Table := tbmak(LASTSW2);
24 tbadd(Sw2Table,S2STRIP,'STRIP-BLANKS',0);
25 tbadd(Sw2Table,S2NOSTR,'NO-STRIP-BLANKS',0);
26
27 Sw3Table := tbmak(LASTSW3);
28 tbadd(Sw3Table,S3SHORT,'SHORT',0);
29 tbadd(Sw3Table,S3FULL,'FULL',0);
30
31 DefTable := tbmak(LASTDEF);
32 tbadd(DefTable,DFWARN,'WARNING-MESSAGES',0);
33 tbadd(DefTable,DFTABEV,'TABS-EVERY',0);
34 tbadd(DefTable,DFSTRIP,'STRIP-BLANKS',0);
35 tbadd(DefTable,DFRECLN,'RECORD-LENGTH',0);
36 tbadd(DefTable,DFNOSWI,'NO',0);
37 tbadd(DefTable,DFBLOCK,'BLOCKING-FACTOR',0);
38
39 NoTable := tbmak(LASTNO);
40 tbadd(NoTable,DFWARN,'WARNING-MESSAGES',0);
41 tbadd(NoTable,DFTABEV,'TABS-EVERY',0);
42 tbadd(NoTable,DFSTRIP,'STRIP-BLANKS',0);
43 end; {of procedure InitTables}
44
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 39
1
2 { DefaultTapeName -- returns the default name and extent from the }
3 { inputted disk name. Tape file names must be 17 chars or less }
4 { including the '.' so in certain cases it must be shortened }
5 procedure DefaultTapeName(var name,ext : FNameType);
6 const
7 MAXTNAME = 17;
8 var
9 NameLen, ExtLen : integer;
10
11 begin
12 jsys(JFNS;name,0:input,001000000000B);
13 NameLen := StrLen(name);
14 jsys(JFNS;ext,0:input,000100000000B);
15 ExtLen := StrLen(ext);
16 {check if name is too long}
17 if (ExtLen > 0) and (NameLen + 1 + ExtLen > MAXTNAME) then begin
18 if (ExtLen > 10) then
19 ExtLen := 10; {leave at least 6 chars for name}
20 NameLen := MAXTNAME - ExtLen - 1;
21 end; {of if}
22 StrEnd(name,NameLen+1);
23 StrEnd(ext,ExtLen+1);
24 end; {of procedure DefaultTapeName}
25
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 40
1
2 { ListFiles -- prints the source and destination filenames }
3 procedure ListFiles;
4 var
5 source, dest : FNameType;
6 begin
7 jsys(JFNS;source,0:input,221110000001B);
8 jsys(JFNS;dest,0:output,221110000001B);
9 space(2);
10 writeln(tty,source:StrLen(source),' => ',dest:StrLen(dest));
11 end; {of procedure ListFile}
12
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 41
1
2 { DefaultDiskFile -- Creates a diskfile name depending on the name }
3 { of the input tape name and the directory to output to }
4 procedure DefaultDiskFile;
5 var
6 FileName : FNameType;
7 begin
8 GlobalDiskFile := GlobalDirStr;
9 jsys(JFNS;FileName,0:input,001100000001B);
10 scopy(FileName,1,GlobalDiskFile,StrLen(GlobalDiskFile)+1);
11 end; {procedure DefaultDiskFile}
12
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 42
1
2 { DefaultTapeFile -- Takes the disk source file and turns it into }
3 { a valid tape file and stores it into GlobalTapeFile. }
4 procedure DefaultTapeFile;
5 var
6 Tname,Text : FNameType;
7 begin
8 DefaultTapeName(Tname,Text);
9 GlobalTapeFile := GlobalTape;
10 GlobalTapeFile[StrLen(GlobalTapeFile)+1] := ':';
11 StrEnd(GlobalTapeFile,StrPos(GlobalTapeFile,':')+1);
12 scopy(Tname,1,GlobalTapeFile,StrLen(GlobalTapeFile)+1);
13 GlobalTapeFile[StrLen(GlobalTapeFile)+1] := '.';
14 StrEnd(GlobalTapeFile,StrPos(GlobalTapeFile,'.')+1);
15 scopy(Text,1,GlobalTapeFile,StrLen(GlobalTapeFile)+1);
16 end; {of procedure DefaultTapeFile}
17
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 43
1
2 { ListRecordCount -- lists the number of records read or written }
3 { from or into a file }
4 procedure ListRecordCount(n : integer);
5 begin
6 space(4);
7 writeln(tty,'[',n:1,' records]');
8 end; {of procedure ListRecordCount}
9
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 44
1
2 { TruncMess -- prints a message saying what line was truncated and }
3 { by how much }
4 procedure TruncMess(line, col : integer);
5 begin
6 jsys(JFNS;101B, 0:input, 0);
7 write(tty, ' - line ', line:1, ' : ', col:1,
8 ' characters long, truncated to ', GlobalRecLen:1);
9 writeln(tty);
10 end; {of procedure TruncMess}
11
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 45
1
2 { SwitchRecLenSw1 -- parses the record-length switch option for the }
3 { store command }
4 procedure SwitchRecLenSw1;
5 var
6 i, RecLen : integer;
7 HelpMess, ErrMess : StrType;
8 begin
9 scopy('integer between 1 and ',1,HelpMess,1);
10 i := itoc(MAXRECLEN,HelpMess,StrLen(HelpMess)+1);
11 cmhlp(HelpMess);
12 cmdef(DEFRECLEN);
13 RecLen := cmnum; {get an integer}
14 if (RecLen < MINRECLEN) or (RecLen > MAXRECLEN) then begin
15 scopy('Record length must be between ',1,ErrMess,1);
16 i := itoc(MINRECLEN,ErrMess,StrLen(ErrMess)+1);
17 scopy(' and ',1,Errmess,StrLen(ErrMess)+1);
18 i := itoc(MAXRECLEN,ErrMess,StrLen(ErrMess)+1);
19 cmuerr(ErrMess);
20 end; {of if}
21 if ((RecLen * HoldBlkFac) > MAXBLKLEN) then begin
22 scopy
23 ('Record length too large with blocking factor of ',1,ErrMess,1);
24 i := itoc(HoldBlkFac,ErrMess,StrLen(ErrMess)+1);
25 cmuerr(ErrMess);
26 end; {of if}
27 HoldRecLen := RecLen; {set global variable}
28 end; {of procedure SwitchRecLenSw1}
29
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 46
1
2 { SwitchNoPadSw1 -- parses the no-pad-tabs switch option for the }
3 { store command }
4 procedure SwitchNoPadSw1;
5 begin
6 HoldPadTabs := false;
7 end; {of procedure SwitchNoPadSw1}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 47
1
2 { SwitchBlockSw1 -- parses the records-per-block switch option for }
3 { the store command }
4 procedure SwitchBlockSw1;
5 var
6 i, BlkFac : integer;
7 HelpMess, ErrMess : StrType;
8 begin
9 cmhlp('number of records per block');
10 cmdef(DEFBLKFAC);
11 BlkFac := cmnum; {get and integer}
12 if (BlkFac = 0) then {0 same as 1}
13 BlkFac := 1;
14 if (BlkFac < 1) or (BlkFac > MAXBLKLEN) then begin
15 scopy('Blocking factor must be between 1 and ',1,ErrMess,1);
16 i := itoc(MAXBLKLEN,ErrMess,StrLen(ErrMess)+1);
17 cmuerr(ErrMess);
18 end; {of if}
19 if ((BlkFac * HoldRecLen) > MAXBLKLEN) then begin
20 scopy
21 ('Blocking factor too large with record length of ',1,ErrMess,1);
22 i := itoc(HoldRecLen,ErrMess,StrLen(ErrMess)+1);
23 cmuerr(ErrMess);
24 end; {of if}
25 HoldBlkFac := BlkFac; {set global variable}
26 end; {of procedure SwitchBlockSw1}
27
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 48
1
2 { SwitchSetTabsSw1 -- parses the tabs-every switch option for the }
3 { store command }
4 procedure SwitchSetTabsSw1;
5 var
6 i, TabNo : integer;
7 HelpMess, ErrMess : StrType;
8 begin
9 scopy('integer between 1 and ',1,HelpMess,1);
10 i := itoc(MAXRECLEN,HelpMess,StrLen(HelpMess)+1);
11 cmhlp(HelpMess);
12 cmdef(DEFTABNO);
13 TabNo := cmnum; {get an integer}
14 if (TabNo < 1) or (TabNo > MAXRECLEN) then begin
15 scopy('Argument must be between 1 and ',1,ErrMess,1);
16 i := itoc(MAXRECLEN,ErrMess,StrLen(ErrMess)+1);
17 cmuerr(ErrMess);
18 end; {of if}
19 HoldTabNo := TabNo; {set global variable}
20 HoldPadTabs := true; {set global variable}
21 end; {of procedure SwitchSetTabsSw1}
22
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 49
1
2 { SwitchNoStripSw2 -- handles the no-strip switch for the restore }
3 { command }
4 procedure SwitchNoStripSw2;
5 begin
6 HoldStripBlanks := false;
7 end; {of procedure SwitchNoStripSw2}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 50
1
2 { SwitchStripSw2 -- handles the strip-blanks switch for the restore }
3 { command }
4 procedure SwitchStripSw2;
5 begin
6 HoldStripBlanks := true;
7 end; {of procedure SwitchStripSw2}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 51
1
2 { SwitchFullDirSw3 -- handles the full switch for the directory }
3 { command }
4 procedure SwitchFullDirSw3;
5 begin
6 HoldDirectory := FullDir;
7 end; {of procedure SwitchFullDirSw3}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 52
1
2 { SwitchShortDirSw3 -- handles the short switch for the directory }
3 { command }
4 procedure SwitchShortDirSw3;
5 begin
6 HoldDirectory := ShortDir;
7 end; {of procedure SwitchShortDirSw3}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 53
1
2 { SwitchWarnMessDf -- handles the Warning Messages option }
3 procedure SwitchWarnMessDf;
4 begin
5 HoldWarning := true;
6 end; {of procedure SwitchWarnMessDf}
7
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 54
1
2 { SwitchNoWarnDf -- turns off the warning messages }
3 procedure SwitchNoWarnDf;
4 begin
5 HoldWarning := false;
6 end; {of procedure SwitchNoWarnDf}
7
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 55
1
2 { SwitchNoSwitchDf -- handles the no option for the default command }
3 procedure SwitchNoSwitchDf;
4 var
5 NoCommand : integer;
6 begin
7 NoCommand := cmkey(NoTable);
8 case NoCommand of
9 DFSTRIP : SwitchNoStripSw2;
10 DFTABEV : SwitchNoPadSw1;
11 DFWARN : SwitchNoWarnDf;
12 others : cmuerr('Invalid switch');
13 end; {of case}
14 end; {of procedure SwitchNoSwitchDf}
15
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 56
1
2 { SaveStoreSwitchesSw1 -- assigns variables storing store switches }
3 { information to global variable. }
4 procedure SaveStoreSwitchesSw1;
5 begin
6 GlobalRecLen := HoldRecLen;
7 GlobalBlkFac := HoldBlkFac;
8 GlobalTabNo := HoldTabNo;
9 GlobalPadTabs := HoldPadTabs;
10 end; {of procedure SaveStoreSwitchesSw1}
11
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 57
1
2 { SaveRestoreSwitchesSw2 -- assigns vriables storing restore }
3 { switches information to global variables }
4 procedure SaveRestoreSwitchesSw2;
5 begin
6 GlobalStripBlanks := HoldStripBlanks;
7 end; {of procedure SaveRestoreSwitchesSw2}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 58
1
2 { SaveDirectorySwitchesSw3 -- assigns vriables storing directory }
3 { switches information to global variables }
4 procedure SaveDirectorySwitchesSw3;
5 begin
6 GlobalDirectory := HoldDirectory;
7 end; {of procedure SaveDirectorySwitchesSw3}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 59
1
2 { SaveDefaults -- saves default settings }
3 procedure SaveDefaults;
4 begin
5 DefaultRecLen := HoldRecLen;
6 DefaultBlkFac := HoldBlkFac;
7 DefaultTabNo := HoldTabNo;
8 DefaultPadTabs := HoldPadTabs;
9 DefaultWarning := HoldWarning;
10 DefaultStripBlanks := HoldStripBlanks;
11 end; {of procedure SaveDefaults}
12
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 60
1
2 { StoreSwitchesSw1 -- parses multiple choices for the store }
3 { command }
4 procedure StoreSwitchesSw1;
5 var
6 switch : integer;
7 begin
8 loop
9 cmmult; {multiple mode}
10 cmcfm; {carriage return}
11 switch := cmswi(Sw1Table);
12 switch := cmdo;
13 exit if (switch = 1);
14 switch := cmint; {get real value from cmswi}
15 if (switch > 0) then
16 case switch of
17 S1NOPAD : SwitchNoPadSw1;
18 others : cmuerr('Argument not specified');
19 end {of case}
20 else if (switch < 0) then {users gave argument, indicated by - }
21 case -switch of
22 S1BLOCK : SwitchBlockSw1;
23 S1RECLN : SwitchRecLenSw1;
24 S1TABEV : SwitchSetTabsSw1;
25 others : cmuerr('Does not take an argument');
26 end; {of case -switch}
27 end; {of loop}
28 end; {of procedure StoreSwitchesSw1}
29
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 61
1
2 { RestoreSwitchesSw2 -- parses multiple choice switches for the }
3 { store command }
4 procedure RestoreSwitchesSw2;
5 var
6 switch : integer;
7 begin
8 cmmult; {multiple mode}
9 cmdef('/STRIP-BLANKS');
10 cmcfm; {cr}
11 switch := cmswi(Sw2Table);
12 switch := cmdo;
13 if (switch <> 1) then begin
14 switch := cmint; {get real value form cmswi}
15 if (switch < 0) then
16 cmuerr('Does not take an argument')
17 else
18 case switch of
19 S2NOSTR : SwitchNoStripSw2;
20 S2STRIP : SwitchStripSw2;
21 others : cmuerr('Invalid switch')
22 end; {of case switch}
23 cmcfm; {cr}
24 end; {of if}
25 end; {of procedure RestoreSwitchesSw2}
26
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 62
1
2 { DirectorySwitchesSw3 -- parses multiple choice switches for the }
3 { Directory command }
4 procedure DirectorySwitchesSw3;
5 var
6 switch : integer;
7 begin
8 cmmult; {multiple mode}
9 cmdef('/SHORT');
10 cmcfm; {carriage return}
11 switch := cmswi(Sw3Table);
12 switch := cmdo;
13 if (switch <> 1) then begin
14 switch := cmint; {get real value form cmswi}
15 if (switch < 0) then
16 cmuerr('Does not take an argument')
17 else
18 case switch of
19 S3FULL : SwitchFullDirSw3;
20 S3SHORT : SwitchShortDirSw3;
21 others : cmuerr('Invalid switch')
22 end; {of case switch}
23 cmcfm; {cr}
24 end; {of if}
25 end; {of procedure DirectorySwitchesSw3}
26
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 63
1
2 { ParseTapeOutput2 -- parses next field as output to tape }
3 procedure ParseTapeOutput2;
4 var
5 Tname,Text : FNameType;
6 TapeFileStr : StrType;
7 TFStrLen : integer;
8 begin
9 cmnoi('AS');
10 CheckIfTapeAssigned;
11 gjgen(600020000000B);
12 DefaultTapeName(Tname,Text);
13 gjdev(GlobalTape);
14 gjnam(Tname);
15 gjext(Text);
16 cmfil(output);
17 TFStrLen := cmatom(TapeFileStr);
18 StrEnd(TapeFileStr,TFStrLen+1);
19 if (StrPos(TapeFileStr,';') <> 0) then {user enters extra junk}
20 GarbageErr
21 ('Invalid attribute for this device',TapeFileStr);
22 if (KindOfDevice(curjfn(output),JFNDes) <> TapeDev) then
23 cmuerr('Use COPY command to copy from disk to disk');
24 end; {of procedure ParseTapeOutput2}
25
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 64
1
2 { ParseDiskOutput2 -- parses next field as output to disk }
3 procedure ParseDiskOutput2;
4 var
5 name, ext : FNameType;
6
7 begin
8 cmnoi('TO');
9 jsys(JFNS;name,0:input,001000000000B);
10 jsys(JFNS;ext,0:input,000100000000B);
11 gjgen(600020000000B);
12 gjnam(name);
13 gjext(ext);
14 cmfil(output);
15 if not (KindOfDevice(curjfn(output),JFNDes) in [DiskDev,TTYDev]) then
16 cmuerr('This utility does not support tape to tape copying');
17 end; {of procedure ParseDiskOutput2}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 65
1
2 { ParseDirOutput2 -- parses next field as a directory name }
3 procedure ParseDirOutput2;
4 const
5 DIRST = 41B;
6 GJINF = 13B;
7 var
8 ac1, ac2, DirNo, DirLen : integer;
9 DefaultDir : StrType;
10 begin
11 jsys(GJINF;;ac1, ac2); {get def dir no}
12 jsys(DIRST;DefaultDir, ac2); {turn it into a string}
13 cmdef(DefaultDir);
14 DirNo := cmdir;
15 DirLen := cmatom(GlobalDirStr);
16 StrEnd(GlobalDirStr,DirLen+1);
17 if (DirLen = 0) then
18 GlobalDirStr := DefaultDir;
19 end; {of procedure ParseDirOutput2}
20
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 66
1
2 procedure RestoreFile;
3 var
4 line, RecLen : integer;
5 next : boolean;
6 buffer : packed array [1..MAXRECLEN] of char;
7 begin
8 line := 0;
9 while not eof do begin
10 next := true;
11 readln(buffer:RecLen);
12 line := line + 1;
13 RecLen := RecLen - 2; {disregard crlf}
14 if GlobalStripBlanks then
15 while (RecLen >= 1) and next do
16 if (buffer[RecLen] = chr(BLANK)) then
17 RecLen := RecLen - 1
18 else
19 next := false;
20 if (RecLen = 0) then
21 writeln
22 else
23 writeln(buffer:RecLen);
24 end; {of while}
25 ListRecordCount(line);
26 end; {of procedure RestoreFile}
27
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 67
1
2 { StoreFile -- processes the store command }
3 procedure StoreFile;
4 var
5 col, line : integer;
6 mess : StrType;
7
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 68
1
2 { NewLine -- handles end of line delimiter and sets up for the next }
3 { line }
4 procedure NewLine;
5 begin
6 if ((col - 1) > GlobalRecLen) then
7 TruncMess(line,col-1);
8 readln;
9 writeln;
10 col := 1;
11 line := line + 1;
12 end; {of procedure NewLine}
13
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 69
1
2 { CopyChar -- copies a single char from input to output and takes }
3 { into account tabs }
4 procedure CopyChar;
5 begin
6 if GlobalPadTabs and (input^ = chr(TAB)) then
7 repeat {pad tabs}
8 if (col <= GlobalRecLen) then begin
9 output^ := chr(BLANK);
10 put(output);
11 end; {of if}
12 col := col + 1;
13 until (TabPos(col))
14 else begin
15 if (col <= GlobalRecLen) then begin
16 output^ := input^;
17 put(output);
18 end; {of if}
19 col := col + 1;
20 end; {of else}
21 get(input);
22 end; {of procedure CopyChar}
23
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 70
1
2 begin {StoreFile}
3 col := 1; line := 1;
4 while not eof do begin {store to tape}
5 if (input^ = chr(CR)) then begin
6 get(input); {check if crlf}
7 if eof then begin {cr eof}
8 if ((col - 1) > GlobalRecLen) then
9 TruncMess(line,col-1);
10 writeln;
11 line := line + 1;
12 end {of if}
13 else if (input^ = chr(LF)) then {crlf}
14 NewLine
15 else begin {treat both cr and next char as normal char's}
16 if (col <= GlobalRecLen) then begin
17 output^ := chr(CR); {add in already read cr}
18 put(output);
19 end; {of if}
20 col := col + 1;
21 CopyChar;
22 end {of else}
23 end {of if}
24 else if (input^ = chr(LF)) then {same as crlf}
25 NewLine
26 else
27 CopyChar;
28 end; {of while not eof}
29 ListRecordCount(line-1);
30 end; {of procedure StoreFile}
31
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 71
1
2 { initialization -- does the initializing }
3 procedure initialization;
4 const
5 INDUSTRY_COMPATIBLE = 4B;
6 begin
7 OriginalDataMode := GetJobDataMode;
8 if (OriginalDataMode <> INDUSTRY_COMPATIBLE) then
9 SetJobDataMode(INDUSTRY_COMPATIBLE);
10 ThatsIt := false;
11 StrEnd(GlobalTape,1); {null string}
12 InitTables;
13 DefaultRecLen := ctoi(DEFRECLEN,1);
14 DefaultBlkFac := ctoi(DEFBLKFAC,1);
15 DefaultTabNo := ctoi(DEFTABNO,1);
16 DefaultWarning := true;
17 DefaultPadTabs := true;
18 DefaultStripBlanks := true;
19 DefaultDirectory := ShortDir;
20 end; {of procedure initialization}
21
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 72
1
2 { PrintHeading -- prints heading when ANSIMT starts up. Prints }
3 { title, version numbers, edit numbers, and date. }
4 procedure PrintHeading;
5 const
6 WHO_EDITED = 2B;
7 MAJOR_VERSION_NUMBER = 001B;
8 MINOR_VERSION_NUMBER = 02B;
9 EDIT_NUMBER = 000001B;
10
11 ODTIM = 220B;
12 var
13 ProgramStartTime : packed array [1..40] of char; {date field}
14 {$V:200102000001b} {system version number}
15 begin
16 writeln(tty,'UHCC DEC-20 ANSI Labelled Tape Utility version ',
17 MAJOR_VERSION_NUMBER:3:O,'.',MINOR_VERSION_NUMBER:2:O,
18 '(',EDIT_NUMBER:6:O,')-',WHO_EDITED:1:O);
19 jsys(ODTIM,1;ProgramStartTime,-1,336321000000B);
20 writeln(tty,ProgramStartTime:StrLen(ProgramStartTime));
21 writeln(tty);
22 end; {of procedure PrintHeading}
23
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 73
1
2 { InitParameters -- initializes the global and dummy variables to }
3 { their default values }
4 procedure InitParameters;
5 begin
6 HoldRecLen := DefaultRecLen;
7 HoldBlkFac := DefaultBlkFac;
8 HoldTabNo := DefaultTabno;
9 HoldPadTabs := DefaultPadTabs;
10 HoldWarning := DefaultWarning;
11 HoldStripBlanks := DefaultStripBlanks;
12 HoldDirectory := DefaultDirectory;
13
14 GlobalRecLen := DefaultRecLen;
15 GlobalBlkFac := DefaultBlkFac;
16 GlobalTabNo := DefaultTabno;
17 GlobalPadTabs := DefaultPadTabs;
18 GlobalWarning := DefaultWarning;
19 GlobalStripBlanks := DefaultStripBlanks;
20 GlobalDirectory := DefaultDirectory;
21 end; {of procedure InitParameters}
22
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 74
1
2 { ParseDefault1 -- parses the default command }
3 procedure ParseDefault1;
4 var
5 DefCommand : integer;
6 begin
7 cmnoi('FOR');
8 DefCommand := cmkey(DefTable);
9 case DefCommand of
10 DFBLOCK : SwitchBlockSw1;
11 DFNOSWI : SwitchNoSwitchDf;
12 DFRECLN : SwitchRecLenSw1;
13 DFSTRIP : SwitchStripSw2;
14 DFTABEV : SwitchSetTabsSw1;
15 DFWARN : SwitchWarnMessDf;
16 others : cmuerr('Invalid switch');
17 end; {of case}
18 cmcfm; {cr}
19 end; {of ParseDefault}
20
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 75
1
2 { ParseDirectory -- parses the directory command }
3 procedure ParseDirectory1;
4 begin
5 cmnoi('OF TAPE');
6 DirectorySwitchesSw3;
7 end; {of procedure ParseDirectory1}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 76
1
2 { ParseEOT1 -- parses the eot command }
3 procedure ParseEOT1;
4 begin
5 cmnoi('END OF TAPE');
6 cmcfm;
7 end; {of procedure ParseEOT1}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 77
1
2 { ParseExit1 -- parses the exit command }
3 procedure ParseExit1;
4 begin
5 cmnoi('TO MONITOR');
6 cmcfm;
7 end; {of procedure ParseExit1}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 78
1
2 { ParseHelp1 -- parses the help command }
3 procedure ParseHelp1;
4 begin
5 cmnoi('ON ANSIMT COMMANDS');
6 cmcfm; {carriage return}
7 end; {of procedure ParseHelp1}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 79
1
2 { ParseRestore1 -- parses the restore command }
3 procedure ParseRestore1;
4 var
5 FileStrLen : integer;
6 FileStr : StrType;
7 begin
8 cmnoi('TAPE FILES');
9 CheckIfTapeAssigned;
10 gjgen(000120777775B);
11 gjdev(GlobalTape);
12 cmfil(input);
13 FileStrLen := cmatom(FileStr);
14 StrEnd(FileStr,FileStrLen+1);
15 if (KindOfDevice(curjfn(input),JFNDes) <> TapeDev) then
16 cmuerr('Device must be TAPE');
17 if (StrPos(FileStr,'*') = 0) and
18 (StrPos(FileStr,'%') = 0) then begin
19 ParseDiskOutput2;
20 jsys(JFNS;GlobalDiskFile,0:output,0);
21 end {of if}
22 else begin
23 ParseDirOutput2;
24 GlobalDiskFile[1] := chr(NULL);
25 end; {of else}
26 RestoreSwitchesSw2;
27 end; {of procedure ParseRestore1}
28
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 80
1
2 { ParseRewind1 -- parses the rewind command }
3 procedure ParseRewind1;
4 begin
5 cmnoi('TO THE BEGINNING OF TAPE');
6 cmcfm;
7 end; {of procedure ParseRewind1}
8
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 81
1
2 { ParseSkip1 -- parses the skip command }
3 procedure ParseSkip1;
4 const
5 DEFNFIL = '1 ';
6 begin
7 cmnoi('NUMBER OF FILES');
8 cmhlp('positive integer for forward, negative for backward');
9 cmdef(DEFNFIL);
10 FilesToSkip := cmnum; {global variable}
11 cmcfm; {carriage return}
12 end; {of procedure ParseSkip1}
13
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 82
1
2 { ParseStore1 -- parses the store command }
3 procedure ParseStore1;
4 var
5 i, FileStrLen : integer;
6 FileStr : StrType;
7 begin
8 cmnoi('DISK FILES');
9 gjgen(100120000000B);
10 cmfil(input);
11 FileStrLen := cmatom(FileStr);
12 StrEnd(FileStr,FileStrLen + 1);
13 if (StrPos(FileStr,'*') = 0) and {wild card?}
14 (StrPos(FileStr,'%') = 0) then begin
15 ParseTapeOutput2;
16 jsys(JFNS;GlobalTapeFile,0:output,0);
17 end {if end}
18 else begin {it is a wild card}
19 DefaultTapeFile;
20 end; {of else}
21 StoreSwitchesSw1;
22 end; {of procedure ParseStore1}
23
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 83
1
2 { ParseTape1 -- parses the tape command }
3 procedure ParseTape1;
4 const
5 ASND = 70B;
6 var
7 DevNo, DevStrLen, return : integer;
8 DevStr : FNameType;
9 begin
10 cmnoi('DEVICE');
11 cmhlp('magtape device');
12 DevNo := cmdev;
13 DevStrLen := cmatom(DevStr);
14 StrEnd(DevStr,DevStrLen+1);
15 if (KindOfDevice(DevNo,DevDes) <> TapeDev) then
16 GarbageErr('Not a magtape device',DevStr);
17 jsys(ASND, 3, return;DevNo); {try to assign the device}
18 if (return = 1) then {error}
19 ErrorMess;
20 cmcfm;
21 HoldTape := DevStr;
22 end; {of procedure ParseTape1}
23
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 84
1
2 { ProcessDefault -- process the default command }
3 procedure ProcessDefault;
4 begin
5 SaveDefaults;
6 end; {of procedure ProcessDefault}
7
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 85
1
2 { ProcessDirectory -- process the directory command }
3 procedure ProcessDirectory;
4 const
5 WILDCARD = ':*.*.*';
6 DATAERR = 600221B; {data error}
7 BIGREC = 601240B;
8 var
9 i : integer;
10 WildFile : FNameType;
11 begin
12 SaveDirectorySwitchesSw3;
13 CheckIfTapeAssigned;
14 RewindTape;
15 WildFile := GlobalTape;
16 scopy(WILDCARD,1,WildFile,StrLen(WildFile)+1);
17 i := 1;
18 repeat
19 reset(input,WildFile,'/d/o/m:7',[11]{allow wildcards});
20 if (erstat(input) <> 0) and
21 (erstat(input) <> DATAERR) and (erstat(input) <> BIGREC) then
22 analysis(input)
23 else begin
24 if (i = 1) then
25 DirHeading;
26 if (erstat(input) = DATAERR) or (erstat(input) = BIGREC) then
27 TapeFileInfo(-i)
28 else
29 TapeFileInfo(i);
30 i := i + 1;
31 end;
32 ClearDataError(input);
33 if FileOpen(input) then
34 close(input);
35 until (nextfile(input) = 0);
36 end; {of procedure ProcessDirectory}
37
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 86
1
2 { ProcessEOT -- processes the eot command }
3 procedure ProcessEOT;
4 const
5 MOEOT = 10B;
6 var
7 return : integer;
8 begin
9 CheckIfTapeAssigned;
10 GetDeviceJFN;
11 jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
12 if (return = 1) then
13 ErrorMess;
14 jsys(MTOPR,-2,return;0:device, MOEOT);
15 if (return = 3) then begin
16 if TrapEOT then
17 WarnMess('Already at end of tape')
18 else
19 cmerrmsg; {print official error message}
20 jsys(CLOSEF, 2, return;001000:device);
21 if (return = 1) then
22 cmerrmsg;
23 cmagain;
24 end {of if}
25 else begin
26 jsys(CLOSEF,2,return;001000:device);
27 if (return = 1) then
28 ErrorMess;
29 end; {of begin}
30 end; {of procedure ProcessEOT}
31
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 87
1
2 { ProcessExit -- processes the exit command }
3 procedure ProcessExit;
4 begin
5 ThatsIt := true; {terminates program in major loop}
6 end; {of procedure ProcessExit}
7
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 88
1
2 { ProcessHelp -- processes the help command }
3 procedure ProcessHelp;
4 var
5 rl : integer;
6 buffer : StrType;
7 begin
8 reset(input,'HLP:ANSIMT.HLP','/o');
9 if (erstat(input) <> 0) then
10 analysis(input);
11 rewrite(output,'TTY:','/o/i');
12 if (erstat(output) <> 0) then
13 analysis(output);
14 while not eof do begin
15 readln(buffer:rl);
16 writeln(buffer:rl);
17 end; {of while}
18 close(input);
19 close(output);
20 end; {of procedure ProcessHelp}
21
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 89
1
2 { ProcessRestore -- processes the restore command }
3 procedure ProcessRestore;
4 begin
5 SaveRestoreSwitchesSw2;
6 loop
7 if OpenInputTape then begin
8 if (GlobalDiskFile[1] = chr(NULL)) then
9 DefaultDiskFile;
10 if not OpenOutputDisk then
11 cmagain;
12 ListFiles;
13 RestoreFile;
14 close(input);
15 close(output);
16 end; {of if}
17 exit if (nextfile(input) = 0);
18 GlobalDiskFile[1] := chr(NULL);
19 end; {of loop}
20 end; {of procedure ProcessRestore}
21
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 90
1
2 { ProcessRewind -- processes the rewind command }
3 procedure ProcessRewind;
4 begin
5 CheckIfTapeAssigned;
6 RewindTape;
7 if BeginningOfTape then
8 WarnMess('Already at beginning of tape');
9 end; {of procedure ProcessRewind}
10
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 91
1
2 { ProcessSkip -- processes the skip command }
3 procedure ProcessSkip;
4 var
5 i : integer;
6 begin
7 CheckIfTapeAssigned;
8 if (FilesToSkip > 0) then
9 for i := 1 to FilesToSkip do
10 ForwardFile
11 else if (FilesToSkip < 0) then
12 for i := 1 to -FilesToSkip do begin
13 BackwardFile;
14 if BeginningOfTape then
15 cmuerr('Beginning of tape encountered');
16 end; {of for}
17 end; {of procedure ProcessSkip}
18
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 92
1
2 { ProcessStore -- processes the store command }
3 procedure ProcessStore;
4 var
5 i : integer;
6 mess : StrType;
7 begin {ProcessStore}
8 SaveStoreSwitchesSw1;
9 if (KindOfDevice(curjfn(input),JFNDes) = DiskDev) then begin
10 if not OpenInputFile(DiskDev) then
11 cmagain;
12 end {of if}
13 else if (KindOfDevice(curjfn(input),JFNDes) = TTYDev) then begin
14 if not OpenInputFile(TTYDev) then
15 cmagain;
16 end {of else if}
17 else
18 cmuerr('Source device must be DISK');
19 loop
20 if not OpenOutputTape(GlobalTapeFile) then
21 cmagain;
22 if (GlobalRecLen * GlobalBlkFac > MAXRECLEN) then begin
23 scopy('Block size greater than the ANSI standard of ',1,mess,1);
24 i := itoc(MAXRECLEN,mess,StrLen(mess)+1);
25 WarnMess(mess);
26 end; {of if}
27 ListFiles;
28 StoreFile;
29 close(input);
30 close(output);
31 exit if (nextfile(input) = 0);
32 if not OpenInputFile(DiskDev) then
33 cmagain;
34 DefaultTapeFile;
35 end; {of loop}
36 end; {of procedure ProcessStore}
37
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 93
1
2 { ProcessTape -- processes the tape command }
3 procedure ProcessTape;
4 const
5 MORLI = 50B;
6 MOSDM = 4B; {set hardware data mode}
7 ARGS = 2B;
8 UNLABELED = 1;
9 ANSILABEL = 2;
10 EBCDICLABEL = 3;
11 TOPS20LABEL = 4;
12 type
13 ArgBlkType = record
14 ArgWords : integer;
15 TypeOfLabel : integer;
16 end; {of record}
17 var
18 DummyTape : FNameType;
19 ArgBlkPtr : ^ArgBlkType;
20 begin
21 new(ArgBlkPtr);
22 DummyTape := GlobalTape;
23 GlobalTape := HoldTape; {set to global variable}
24 with ArgBlkPtr^ do begin
25 ArgWords := ARGS;
26 GetDeviceJFN;
27 jsys(MTOPR;0:device,MORLI,ArgBlkPtr);
28 if (TypeOfLabel = UNLABELED) then begin
29 GlobalTape := DummyTape; {get back old value}
30 cmuerr('Tape cannot be unlabelled');
31 end {of if}
32 else if (TypeOfLabel = EBCDICLABEL) then
33 WarnMess('EBCDIC tape, read only')
34 else if (TypeOfLabel = TOPS20LABEL) then
35 WarnMess('TOPS-20 tape');
36 end; {of with}
37 {get rid of junk}
38 dispose(ArgBlkPtr);
39 end; {of procedure ProcessTape}
40
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 94
1
2 { termination -- cleans up before exiting }
3 procedure termination;
4 const
5 INDUSTRY_COMPATIBLE = 4B;
6 begin
7 if (OriginalDataMode <> INDUSTRY_COMPATIBLE) then
8 SetJobDataMode(OriginalDataMode);
9 end; {of procedure termination}
10
PASCAL %14(331) 19-Dec-85 ANSIMT PAGE 95
1
2 begin {main program}
3 initialization;
4 PrintHeading;
5 repeat
6 cminir('ANSIMT>');
7 InitParameters;
8 command := cmkey(CmdTable);
9 case command of {parse the command}
10 DEF : ParseDefault1;
11 DIR : ParseDirectory1;
12 EOT : ParseEOT1;
13 XIT : ParseExit1;
14 HELP : ParseHelp1;
15 RESTORE : ParseRestore1;
16 REWIND : ParseRewind1;
17 SKIP : ParseSkip1;
18 STORE : ParseStore1;
19 TAPE : ParseTape1;
20 end; {of case}
21 case command of {now process the command}
22 DEF : ProcessDefault;
23 DIR : ProcessDirectory;
24 EOT : ProcessEOT;
25 XIT : ProcessExit;
26 HELP : ProcessHelp;
27 RESTORE : ProcessRestore;
28 REWIND : ProcessRewind;
29 SKIP : ProcessSkip;
30 STORE : ProcessStore;
31 TAPE : ProcessTape;
32 end; {of case}
33 until ThatsIt;
34 termination;
35 end.
No error detected
Highseg: 24P
Lowseg : 1P