-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathnre_scan.pas
1015 lines (899 loc) · 34.9 KB
/
nre_scan.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{$U+,R+}
program nre_scan;
(*
Version 1.5
for PC/MS-DOS
Written by: Michael Roberts
3103 Glenview
Royal Oak, Mi 48073
Compuserve : 74226,3045
This program is built on a listing program by Rick Schaeffer.
Modified by: Earl Hall
5619 N. Spaulding #3
Chicago, IL 60659
CompuServe : 72746,3244
Please let me know if you run into any problems or have any
suggestions. This program is currently going through major
revisions (see revision history below), so stay tuned!
======== Revision History =======
9/18/85 - Changes due to the use of DOS file handles in Turbo 3.x:
(ver 1.1) 1. Changed WhenCreated procedure to use DOS function 57h
to get date/time from file handle.
(Probably means that it won't work with older
versions of the Turbo compiler. Oh, well.)
2. Added file close to ListIt procedure.
Otherwise, program would run out of file handles.
- Fixed problem where program was printing the last line of
an included file twice.
- Include REPEATs in the count of block levels ('B' column).
- Changed filename of reserved words to TURBOPRT.RES.
- Include blank lines, and those with supported psuedo
operations ($I,$L+,$L-,.PAGE), in line count (like Turbo's
editor and compiler do). ($L+,$L-, and .PAGE lines are
still not printed.)
- Fixed PrintLine procedure; was failing to print if heading
had to be printed first.
- Added check for position on paper to avoid {.PAGE} directive
causing an extra skip to top of form.
9/19/85 - Add printer control codes for Gemini 10x printer. Original
(ver 1.2) printer codes remain (commented out). "Compressed" mode
on Gemini means to use Elite (12 cpi) font.
- Clean-up of printer forms positioning. Actions specified by
"maxline" and "top_margin" constants are exact. In all
cases, lines are printed and then linect is compared to
maxline. Deleted extra formfeeds. Program now assumes
that paper is initially positioned at top-of-form and will
skip to top-of-form at end of listing.
- Fixed Cross-Reference problem which caused 2nd and subsequent
print lines of line numbers for an entry to list 11
line numbers (instead of 10).
- Fixed bug that disallowed counting of REPEATs in "B" column.
9/21/85 - Changed output to use the same font for the entire line;
(ver 1.3) switching from normal to compressed in mid-line caused
the printer to print in "one-direction" mode.
- Added (commented out) printer codes for the Epson FX-series
printers. I have a Star Gemini-10x, so they haven't
been tested.
- Changed Comment indicator from a number to a 'C'. Program was
not correctly picking up the end of comments if 2 or more
begin-comments of the same type were used before an end-
comment of that type (Turbo doesn't nest comments).
- Fixed problem where program was not recognising BEGINs, ENDs,
etc. if they were immediately followed by a comment.
- Minor attempt at optimisation of Scan_Line procedure.
- An 'I' will now be printed in front of the line number while
expanding Include files (like Turbo's compiler).
- Changed program so that all printed lines will be numbered.
Also changed logic of file reads so that the line
numbering will be exactly like Turbo's (CR/LF followed
by CTRL-Z is considered another line).
(Well, almost exactly! Turbo stops looking at the text
when it sees an "END.", while this program will continue
to list the file past the end of program.)
9/23/85 - Added the Reserved Word list to the program, as a string array,
(ver 1.4) removing the requirement for the TURBOPRT.RES file.
- Changed the Reserved Word lookup to a binary search on the
string array. Speeds up the program a bit.
- Modified the program to use the Turbo ParamCount, ParamStr
functions and Read(Kbd,..).
- Changed the program to print variables up to 25 characters in
length without truncation.
9/28/85 - Changed structure of Xref word records from a linked
(ver 1.5) list to a B-tree. Records storing line numbers now contain
multiple occurances of line numbers.
- More optimisation in Scan_Line procedure.
====== Future Desires ======
(for this program, that is)
I want to add some features to this program in the future. Some
of them are:
- More gracefully handle the printing of long (>80 chars) lines,
which are currently just truncated.
- Change the "Console or Printer" output option to allow direction
to any device. The Console output is really only useful with
very small programs or for debugging purposes.
- Fix up the command line parsing so the program can be run
from batch files. Maybe also allow the use of wildcards for
specifying what programs to list.
Then, some biggies:
- Lex-level analysis of procedures and variables, so that variables
of the same name declared in different procedures will be
handled properly. I'd like this to include some kind of
"level" indication on the program listing, also, so you could
easily spot procedures within procedures, etc.
- Inclusion of procedures in the cross-reference. This would
include detection of redefinition of Standard Turbo Pascal
identifiers. It would also have to include forward references.
- Listing of identifier type (integer, real, etc.) in the cross-
reference and of what procedure.
- Retain, in the cross-reference, the use of upper/lower case
letters as used when the indentifier was declared.
Put these all together and we get something like:
ListIt 833 Procedure, of TurboPrt; forward at 688
728 950
monthmask 398 Constant, of WhenCreated
415
MoreRefs 431 RefsPtr, of BuildXref
453 454 455 456 458 460 461
MoreRefs 884 RefsPtr, of ListXref
891 895 896 898 908 911
RefsPtr 228 Type, of TurboPrt
234 240 431 884
*)
{.page}
(*
Supported pseudo operations:
1. Listing control: {.L-} turns it off, {.L+} turns it back on.
Must be in column 1 and only entry on the line.
2. Page ejection: {.PAGE}, must be in column 1 and only entry
on the line.
When program is first run will check for a file name passed by DOS, and
will try to open that file. If no name is passed, will ask operator for
a file name to open. Proc will tell operator if file doesn't exist and
will allow multiple retrys.
Optionally the file name can be passed via the command line. Typing an
"/I" after the filename will expand includes. Examples:
TurboPrt - Will invoke program and ask for file name to be listed.
TurboPrt MyProg.pas - Will list file "MYPROG.PAS" and not expand
includes.
TurboPrt MyProg /i - Will list file "MYPROG.PAS" and will expand
includes.
On 2nd and later executions, program will not check for DOS passed file
name. In all cases, the program will assume a file type of .PAS if file
type is not specified. Program will exit when a null string is
encountered in response to a file name request.
*)
{.page}
const
maxline = 64; {last line on page to print}
top_margin = 1; {lines to skip after top-of-form}
header_length = 5; {number of lines taken up by page header}
{ to customize code for your printer - adjust the next items }
{ The following codes are for a Gemini 10x - "Compressed" is Elite print }
cp = #27#66#2; {Elite font}
rp = #27#66#1; {regular (Pica) font }
{ The following codes should work on an Epson FX-series printer }
(*
cp = #27#77; {Elite font}
rp = #27#80; {regular (Pica) font }
*)
{ These printer codes were in the original program and are for
(I assume) the Epson MX/IBM graphics printers. }
(*
cp = #15; {compressed print}
rp = #18; {regular width }
*)
cr = #13;
lf = #10;
ff = #12;
Type
two_letters = string[2];
dtstr = string[8];
fnmtype = string[40];
instring = string[135];
regpack = record
ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
end;
Var
First : boolean; {true when prog is run}
answer : char;
Buff1 : instring; {input line buffer}
Wordchk : string[25];
heaptop : ^Integer;
listfil : text; {FIB for LST: or CON: output}
infile : text; {FIB for input file}
fnam : fnmtype; {input file name}
file_path : fnmtype; {path to input file}
bcount : integer; {begin/end counter}
linect : integer; {output file line counter}
RefLine : integer; {Line Reference number counter}
pageno : integer; {page counter}
offset : integer;
print : boolean; (* {.L-} don't print *)
(* {.L+} print *)
print_head : boolean;
Print_Xref : boolean;
path_found : boolean;
Word_switch : boolean;
skip_this_line: boolean;
comment_brace : boolean;
comment_paren : boolean;
c, Print_opt : char;
comment_char : char;
include_char : char;
month, day, year,
hour, minute, second : two_letters;
sysdate, systime,
filedate, filetime : dtstr;
expand_includes : boolean;
holdarg : instring;
allregs : regpack;
{.page}
{ Xref stuff begins here }
const
RefsPerRec = 10;
NumReservedWords = 244;
BiggestReservedWord = 15;
type
ReservedWord = String[BiggestReservedWord];
XrefPtr = ^XrefRec;
RefsPtr = ^RefsRec;
XrefRec = Record
RefWord : string[25];
LeftPtr : XrefPtr;
RightPtr : XrefPtr;
NextRefs : RefsPtr;
end;
RefsRec = record
NumRefs : 0..RefsPerRec;
Refs : Array [1..RefsPerRec] of Integer;
NextRefs : RefsPtr;
end;
var
WordTree : XRefPtr;
ReservedWordCheck : ReservedWord;
const
ReservedWordList : array [1..NumReservedWords] of ReservedWord =
(
'ABS' ,'ABSOLUTE' ,'ADDR'
,'AND' ,'APPEND' ,'ARC'
,'ARCTAN' ,'ARRAY' ,'ASSIGN'
,'AUX' ,'AUXINPTR' ,'AUXOUTPTR'
,'BACK' ,'BEGIN' ,'BLACK'
,'BLINK' ,'BLOCKREAD' ,'BLOCKWRITE'
,'BLUE' ,'BOOLEAN' ,'BROWN'
,'BUFLEN' ,'BYTE' ,'CASE'
,'CHAIN' ,'CHAR' ,'CHDIR'
,'CHR' ,'CIRCLE' ,'CLEARSCREEN'
,'CLOSE' ,'CLREOL' ,'CLRSCR'
,'COLORTABLE' ,'CON' ,'CONCAT'
,'CONINPTR' ,'CONOUTPTR' ,'CONST'
,'CONSTPTR' ,'COPY' ,'COS'
,'CRTEXIT' ,'CRTINIT' ,'CSEG'
,'CYAN' ,'DARKGRAY' ,'DELAY'
,'DELETE' ,'DELLINE' ,'DISPOSE'
,'DIV' ,'DO' ,'DOWNTO'
,'DRAW' ,'DSEG' ,'EAST'
,'ELSE' ,'END' ,'EOF'
,'EOLN' ,'ERASE' ,'EXECUTE'
,'EXIT' ,'EXP' ,'EXTERNAL'
,'FALSE' ,'FILE' ,'FILEPOS'
,'FILESIZE' ,'FILLCHAR' ,'FILLPATTERN'
,'FILLSCREEN' ,'FILLSHAPE' ,'FLUSH'
,'FOR' ,'FORM' ,'FORWARD'
,'FRAC' ,'FREEMEM' ,'FUNCTION'
,'GETDIR' ,'GETDOTCOLOR' ,'GETMEM'
,'GETPIC' ,'GOTO' ,'GOTOXY'
,'GRAPHBACKGROUND' ,'GRAPHCOLORMODE' ,'GRAPHMODE'
,'GRAPHWINDOW' ,'GREEN' ,'HALT'
,'HEADING' ,'HEAPPTR' ,'HI'
,'HIDETURTLE' ,'HIRES' ,'HIRESCOLOR'
,'HOME' ,'IF' ,'IN'
,'INLINE' ,'INPUT' ,'INSERT'
,'INSLINE' ,'INT' ,'INTEGER'
,'INTR' ,'IORESULT' ,'KBD'
,'KEYPRESSED' ,'LABEL' ,'LENGTH'
,'LIGHTBLUE' ,'LIGHTCYAN' ,'LIGHTGRAY'
,'LIGHTGREEN' ,'LIGHTMAGENTA' ,'LIGHTRED'
,'LN' ,'LO' ,'LONGFILEPOS'
,'LONGFILESIZE' ,'LONGSEEK' ,'LOWVIDEO'
,'LST' ,'LSTOUTPTR' ,'MAGENTA'
,'MARK' ,'MAXAVAIL' ,'MAXINT'
,'MEM' ,'MEMAVAIL' ,'MEMW'
,'MEMW' ,'MKDIR' ,'MOD'
,'MOVE' ,'MSDOS' ,'NEW'
,'NIL' ,'NORMVIDEO' ,'NORTH'
,'NOSOUND' ,'NOT' ,'NOWRAP'
,'ODD' ,'OF' ,'OFS'
,'OR' ,'ORD' ,'OUTPUT'
,'OVERLAY' ,'OVRPATH' ,'PACKED'
,'PALETTE' ,'PARAMCOUNT' ,'PARAMSTR'
,'PATTERN' ,'PENDOWN' ,'PENUP'
,'PI' ,'PLOT' ,'PORT'
,'PORTW' ,'POS' ,'PRED'
,'PROCEDURE' ,'PROGRAM' ,'PTR'
,'PUTPIC' ,'RANDOM' ,'RANDOMIZE'
,'READ' ,'READLN' ,'REAL'
,'RECORD' ,'RED' ,'RELEASE'
,'RENAME' ,'REPEAT' ,'RESET'
,'REWRITE' ,'RMDIR' ,'ROUND'
,'SEEK' ,'SEEKEOF' ,'SEEKEOLN'
,'SEG' ,'SET' ,'SETHEADING'
,'SETPENCOLOR' ,'SETPOSITION' ,'SHL'
,'SHOWTURTLE' ,'SHR' ,'SIN'
,'SIZEOF' ,'SOUND' ,'SOUTH'
,'SQR' ,'SQRT' ,'SSEG'
,'STR' ,'STRING' ,'SUCC'
,'SWAP' ,'TEXT' ,'TEXTBACKGROUND'
,'TEXTCOLOR' ,'TEXTMODE' ,'THEN'
,'TO' ,'TRM' ,'TRUE'
,'TRUNC' ,'TRUNCATE' ,'TURNLEFT'
,'TURNRIGHT' ,'TURTLETHERE' ,'TURTLEWINDOW'
,'TYPE' ,'UNTIL' ,'UPCASE'
,'USR' ,'USRINPTR' ,'USROUTPTR'
,'VAL' ,'VAR' ,'WEST'
,'WHEREX' ,'WHEREY' ,'WHILE'
,'WHITE' ,'WINDOW' ,'WITH'
,'WRAP' ,'WRITE' ,'WRITELN'
,'XCOR' ,'XOR' ,'YCOR'
,'YELLOW'
);
function Reserved(var w : ReservedWord ) : boolean;
var
low, high, mid : integer;
done : boolean;
begin
Reserved := False;
done := False;
low := 1;
high := NumReservedWords;
while (low <= high) and not done do
begin
mid := (low + high) div 2;
if w < ReservedWordList[mid] then
high := mid - 1
else
if w > ReservedWordList[mid] then
low := mid + 1
else
begin
Reserved := true;
done := True;
end;
end;
end;
{.page}
procedure fill_blanks (var line: dtstr);
var
i : integer;
begin
for i:= 1 to 8 do
if line[i] = ' ' then
line[i]:= '0';
end; {fill_blanks}
procedure getdate(var date : dtstr);
begin
allregs.ax := $2A * 256;
MsDos(allregs);
str((allregs.dx div 256):2,month);
str((allregs.dx mod 256):2,day);
str((allregs.cx - 1900):2,year);
date := month + '/' + day + '/' + year;
fill_blanks (date);
end; {getdate}
procedure gettime(var time : dtstr);
begin
allregs.ax := $2C * 256;
MsDos(allregs);
str((allregs.cx div 256):2,hour);
str((allregs.cx mod 256):2,minute);
str((allregs.dx div 256):2,second);
time := hour + ':' + minute + ':' + second;
fill_blanks (time);
end; {gettime}
procedure WhenCreated (var date, time: dtstr; var infile: text);
const
monthmask = $000F;
daymask = $001F;
minutemask = $003F;
secondmask = $001F;
var
fulltime,fulldate: integer;
begin
allregs.ax := $57 * 256;
allregs.bx := memw [seg(infile):ofs(infile)];
MsDos(allregs);
fulldate := allregs.dx;
fulltime := allregs.cx;
str(((fulldate shr 9) + 80):2,year);
str(((fulldate shr 5) and monthmask):2,month);
str((fulldate and daymask):2,day);
date:= month + '/' + day + '/' + year;
fill_blanks(date);
str((fulltime shr 11):2,hour);
str(((fulltime shr 5) and minutemask):2,minute);
str(((fulltime and secondmask) * 2):2,second);
time:= hour + ':' + minute + ':' + second;
fill_blanks (time);
end; {WhenCreated}
Procedure BuildXref (var TreePtr : XrefPtr);
var
MoreRefs : RefsPtr;
Begin
if TreePtr = nil then
begin
New(TreePtr);
TreePtr^.RefWord := Wordchk;
TreePtr^.LeftPtr := Nil;
TreePtr^.RightPtr := Nil;
New(TreePtr^.NextRefs);
TreePtr^.NextRefs^.NumRefs := 1;
TreePtr^.NextRefs^.Refs[1] := Refline;
TReePtr^.NextRefs^.NextRefs := Nil;
end
else
if Wordchk < TreePtr^.RefWord then
BuildXref(TreePtr^.LeftPtr)
else
if Wordchk > TreePtr^.RefWord then
BuildXref(TreePtr^.RightPtr)
else
begin
MoreRefs := TreePtr^.NextRefs;
While MoreRefs^.NextRefs <> Nil Do
MoreRefs := MoreRefs^.NextRefs;
if MoreRefs^.Refs[MoreRefs^.NumRefs] <> Refline then
begin
if MoreRefs^.NumRefs = RefsPerRec then
begin
New(MoreRefs^.NextRefs);
MoreRefs := MoreRefs^.NextRefs;
MoreRefs^.NumRefs := 0;
MoreRefs^.NextRefs := Nil;
end;
MoreRefs^.NumRefs := MoreRefs^.NumRefs + 1;
MoreRefs^.Refs[MoreRefs^.NumRefs] := Refline;
end;
end;
end;
procedure print_heading(filename : fnmtype);
var offset_inc: integer;
temp : integer;
begin
if print then
begin
pageno := pageno + 1;
if not (pageno = 1) then
write(listfil, ff); {top of form}
linect := 0;
for temp := 1 to top_margin do
writeln(listfil);
if print_opt = 'C' then
write(listfil,rp);
write(listfil,'TURBO Pascal Program Lister');
writeln(listfil,' ':13,'Printed: ',sysdate,' ',
systime,' Page ',pageno:4);
if filename <> fnam then begin
offset_inc:= 26 - length (filename);
write(listfil,'Include File: ',filename,' ':offset_inc,
'Created: ',filedate,' ',filetime);
end
else write(listfil,'Main File: ',fnam,' ':offset,
'Created: ',filedate,' ',filetime);
writeln(listfil); writeln(listfil);
if print_opt = 'C' then
write(listfil,cp);
If Print_Xref then
begin
Writeln(Listfil,' ':40,'Cross-Reference');
writeln(listfil,'------------------------------',' '
,'-----+-----+-----+-----+-----+-----+-----+-----+-----+-----+');
end
else
begin
writeln(listfil,' line# C B');
writeln(listfil,' ----- - - ---------+---------+---------+'
+'---------+---------+---------+---------+---------+');
end;
linect := top_margin + header_length;
end; {check for print}
end; {print_heading}
procedure printline(iptline : instring; filename : fnmtype);
begin
if print then
begin
writeln(listfil,' ',iptline);
linect := linect + 1;
if linect >= maxline then
print_heading(filename);
end; {check for print}
end; {printline}
{.page}
function chkinc(var iptline : instring; var incflname : fnmtype) : boolean;
var
done : boolean;
i, j : integer;
begin
i := 4; j := 1; incflname := '';
if ((copy(iptline, 1, 3) = '{$I') or
(copy(iptline, 1, 4) = '(*$I')) then begin
if copy(iptline, 1, 4) = '(*$I' then i := 5;
incflname := '';
while (iptline[i] = ' ') and (i <= length(iptline)) do i := i + 1;
done := false;
while not done do begin
if i <= length(iptline) then begin
if not (iptline[i] in [' ','}','+','-','*']) then begin
incflname[j] := iptline[i];
i := i + 1; j := j + 1;
end else done := true;
end else done := true;
if j > 14 then done := true;
end;
incflname[0] := chr(j - 1);
end;
if incflname <> '' then
begin
chkinc := true;
for i := 1 to length(Incflname) do
incflname[i] := upcase(incflname[i]);
end
else
chkinc := false;
end; {chkinc}
PROCEDURE GET_IN_FILE; {GETS INPUT FILE NAME }
var
existing : boolean;
i : integer;
begin
repeat {until file exists}
clrscr;
gotoxy(25,1);
write('TurboPrt - Release 1.5');
if first and (ParamCount > 0) then
fnam := ParamStr(1)
else
begin
gotoxy(1,3);
write(' Enter Filename to List or <CR> to Exit ');
readln(fnam);
if fnam <> '' then
begin
answer := ' ';
writeln;write(' Expand Includes? (Y/N) ');
read(Kbd,answer);
Answer := UpCase(Answer);
if answer = 'Y' then
expand_includes := true
else
begin
expand_includes := false;
answer := 'N';
end;
Writeln(answer);
end
end;
if fnam = '' then {***** EXIT *****}
begin
clrscr;
halt;
end;
for i := 1 to length(fnam) do
fnam[i] := upcase(fnam[i]);
if pos('.',fnam) = 0 then {file type given?}
fnam := concat(fnam,'.PAS'); {file default to .PAS type}
{get optional command line argument # 2}
if first and (ParamCount > 1) then
begin
holdarg := ParamStr(2);
for i := 1 to Length(holdarg) do
holdarg[i] := UpCase(holdarg[i]);
expand_includes := holdarg = '/I';
end;
assign( infile, fnam);
{$I-}
reset( infile ); {check for existence of file}
{$I+}
existing := (ioresult = 0); {true if file found}
if not existing then
begin
writeln;
writeln(' File Doesn''t Exist!!'); {tell operator the sad news}
sound(500);
delay(250);
nosound;
delay(2000);
end;
if existing then
begin {obtain path for include files}
I := length(fnam);
path_found := false;
while ((I > 0) and Not Path_found) do
if (fnam[i] in ['\',':']) then Path_found := true
else I := I - 1;
if Path_found then
begin
file_path := copy(fnam,1,I);
fnam := copy(fnam,(i+1),(length(fnam)));
end;
end;
first := false; {get passed file name only once}
until existing; {until file exists}
end; {GET_IN_FILE}
{ GET_OUT_FILE procedure asks operator to select output to console
device or list device, and then assigns and resets a file control
block to the appropriate device. 'C' or 'P' is only correct
response, and multiple retrys are allowed. }
Procedure Get_Out_File;
begin
repeat {until good selection}
gotoxy(1,7);
clreol;
write(' Output Listing to (C)onsole or (P)rinter ? ');
Read(Kbd,c);
c := upcase(c); write(c);
until c in ['C', 'P'];
writeln;
if c = 'C' then
begin
assign (listfil, 'CON:');
print_opt := 'R';
end
else
assign (listfil, 'LST:');
reset(listfil);
if c = 'P' then begin
repeat
gotoxy(1,9);
clreol;
Write(' (C)ompressed Print or (R)egular Print ? ');
Read(Kbd,print_opt);
print_opt := upcase(print_opt);
write(print_opt);
until print_opt in ['C','R'];
writeln;
if print_opt = 'R' then write(listfil,rp);
end;
end; {GET_OUT_FILE}
{.page}
Procedure ListIt(filename : fnmtype); forward;
// this is where each line is scanned
Procedure Scan_Line;
{ Scan_Line procedure scans one line of Turbo Pascal source code
looking for Begin/End pairs, Case/End pairs, Literal fields
and Comment fields. Bcount is begin/end and case/end counter.
Begin/case/ends are only valid outside of comment fields and
literal constant fields.
Some of the code in the Scan_Line procedure appears at first glance
to be repitive and/or redundant, but was added to speed up the
process of scanning each line of source code.}
var
literal : boolean; { true if in literal field}
i, j : integer; {loop variable index}
buff2 : instring; {working line buffer}
incflname : fnmtype; {in file name}
filedate_save : dtstr;
filetime_save : dtstr;
begin
literal := false;
{copy input buffer to working buffer}
buff2 := concat(buff1, ' ');
for i := 1 to length(buff2) do
buff2[i] := UpCase(buff2[i]); // Don't have to do this; uppercase works
RefLine := RefLine + 1; // Probably line no.
// Include file checker
if chkinc(buff2, incflname) and expand_includes then
// in the case of an include file, recursively process
begin
for i := 1 to length(incflname) do // unnecessary - filenames can be used as is
incflname[i] := upcase(incflname[i]);
if pos('.',incflname) = 0 then incflname := incflname + '.PAS'; // actually we have choice of extensions now
printline(' ******* Including "'
+incflname+'" *******', incflname);
filedate_save := filedate; {save filedate & filetime for}
filetime_save := filetime; {main file }
include_char := 'I';
listit(incflname); // recursive call
include_char := ' ';
filedate := filedate_save; {restore} // restore prior
filetime := filetime_save;
printline(' ******* End of "'
+incflname+'" *******', incflname);
skip_this_line := true; // probably ifgnores rst of line; may want to change this
end {include file check}
else begin
if ((buff2[1] = '{') and (buff2[2] = '.')) then // {. commands
if buff2[3] in ['L','P'] then // (.L or {.P
if copy(buff2,1,7) = '{.PAGE}' then // move to next page
begin
if print and (linect > (header_length + top_margin)) then
begin
skip_this_line := true;
print_head := true;
end;
end
else
if copy(buff2,1,5) = '{.L+}' then // {.L+ /{.:- list on/off
begin
skip_this_line := true;
print := true;
end
else
if copy(buff2,1,5) = '{.L-}' then // {.L+ /{.:- list on/off
begin
skip_this_line := true;
print := false;
end;
buff2 := concat(' ', buff2); {add on some working space}
i := 1;
while buff2[i] = ' ' do // skip blanks
i := i + 1;
while i <= (length(buff2) - 6) do // if not at eol
begin
if not literal then {possible to find comment delim} // literal = "open code"
begin {determine if comment area delim}
if buff2[i] in ['{', '}', '(', '*'] then .. check for comments
begin
if (buff2[i] = '{') then comment_brace := true
else
if (buff2[i] = '}') then comment_brace := false
else
if (copy(buff2,i,2)='(*') then comment_paren := true
else
if (copy(buff2,i,2)='*)') then comment_paren := false;
end;
end
else
while buff2[i] <> chr(39) do // inside quoted string
i := i + 1;
if not (comment_brace or comment_paren) then {in comment area}
begin
if buff2[i] = chr(39) then
literal := not literal; {toggle literal flag}
if not literal then
begin .// "word_switch =
if not Word_switch then
if ((buff2[i] in ['A'..'Z']) and
(not (buff2[i-1] in ['0'..'9','A'..'Z']))) then
Begin
Word_switch := true;
Wordchk := '';
end;
if word_switch then
if (buff2[i] in ['A'..'Z','0'..'9','_']) then
Wordchk := concat(Wordchk,Buff2[i])
else
begin
word_switch := false;
ReservedWordCheck := Wordchk;
if not Reserved(ReservedWordCheck) then
BuildXref (WordTree)
else
begin
if ((Wordchk = 'BEGIN') or
(Wordchk = 'CASE') or
(Wordchk = 'REPEAT')) then
bcount := succ(bcount)
else
if ((Wordchk = 'END') or
(Wordchk = 'UNTIL')) then
if bcount > 0 then
bcount := pred(bcount);
end;
end;
end;
end; { if in comment }
i := i + 1;
end; { for i := }
if comment_brace or comment_paren then
comment_char := 'C'
else
comment_char := ' ';
end;
end; {SCAN_LINE}
{.page}
Procedure ListIt;
var
infile : text;
full_filename : fnmtype;
end_of_it : boolean;
begin
if path_found then
full_filename := concat(file_path,filename)
else
Full_filename := filename;
assign(infile, full_filename);
{$I-} reset(infile) {$I+} ;
if IOresult <> 0 then begin
writeln ('File ',filename,' not found.');
halt;
end;
WhenCreated (filedate,filetime,infile);
if filename = fnam then
print_heading(filename);
end_of_it := false;
while not end_of_it do
begin
buff1 := '';
read(infile, buff1);
scan_line;
if print_head then
begin
print_heading(filename);
print_head := false;
end;
if skip_this_line then
skip_this_line := false
else
if print then
begin
if length(buff1) > 80 then
buff1 := copy(buff1,1,80);
writeln(listfil,include_char,' ',RefLine:5
,' ',comment_char,bcount:2,' ',buff1);
linect := linect + 1;
if linect >= maxline then
print_head := true;
end;
end_of_it := eof(infile);
if not end_of_it then
readln(infile);
end; {while not eof}
close(infile);
end; {ListIt}
Procedure ListXref (TreePtr : XrefPtr);
var
MoreRefs : RefsPtr;
i, x : integer;
Begin
if TreePtr <> nil then
begin
LIstXref (TreePtr^.LeftPtr);
MoreRefs := TreePtr^.NextRefs;
x := 32 - Length(TreePtr^.RefWord);
Write(listfil,TreePtr^.RefWord,' ':x);
x := 0;
MoreRefs := TreePtr^.NextRefs;
While not (MoreRefs = Nil) do
begin
for i := 1 to MoreRefs^.NumRefs do
begin
if x = 10 then
begin
Writeln(listfil);
Linect := Linect + 1;
if Linect >= maxline then Print_heading(fnam);
Write(listfil,' ':32);
x := 0;
end;
Write(listfil,MoreRefs^.Refs[i]:6);
x := x + 1;
end;
MoreRefs := MoreRefs^.NextRefs;
end;
Writeln(listfil);
Linect := Linect + 1;
if Linect >= maxline then Print_heading(fnam);
ListXref (TreePtr^.RightPtr);
end;
end;
{.page}
begin {main procedure}
lowvideo;
getdate(sysdate);
gettime(systime);
expand_includes := false; {default settings}
First := True;
Mark(heaptop);
repeat {forever}
Print_opt := ' ';
WordTree := nil;
ClrScr;
GotoXY(2, 2);
get_in_file; {file to list}
offset := 29 - length(fnam);
get_out_file; {where to list it}
pageno := 0;
linect := 0; {output line counter}
RefLine := 0;
bcount := 0;
print := true;
skip_this_line := false;
print_head := false;
Print_xref := False;
word_switch:= False;
comment_brace := false;