home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / WHATV2.ZIP / WHAT.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1987-02-14  |  16.9 KB  |  513 lines
  1. PROGRAM what;
  2.  
  3. (* Compiles a list of functions and procedures in a file *)
  4. (* that is generated from your TURBO PASCAL programs.    *)
  5. (* Useful to help remember what procedures and functions *)
  6. (* You have in a particular file. Would be nice to have  *)
  7. (* it automatically include TURBO PASCALS include files  *)
  8. (* will get to that one of these days.                   *)
  9. (* Puts in the appropriate characters so the list can    *)
  10. (* be used as comments in your main program.             *)
  11. (* Released to Public Domain for any use whatsoever.     *)
  12. (* William L. Mabee, CRNA                                *)
  13.  
  14. LABEL start,escape;
  15.  
  16. TYPE
  17.  charset = SET OF CHAR;
  18.  fieldtype = (alpha,dollar,numeric,yesno);
  19.  anystr  = STRING[128];
  20.  str80   = STRING[80];
  21.  str2    = STRING[2];
  22.  str14   = STRING[14];
  23.  STR     = STRING[128];
  24.  name    = STRING[14];
  25.  prtype  = (cpi10,cpi12,cpi17,wide,RESET,correspond,dp,
  26.            enhanced,emphacized,normal,form,superon,
  27.            superoff,subon,suboff,underon,underoff);
  28.  
  29.  
  30. CONST
  31.  
  32. dash    = '(*--------------------------------------------------------------------------*)';
  33. open   ='(*                                                                          *)';
  34. okidata = TRUE;
  35. cr      = ^m;          { Keyboard constants }
  36. lf      = ^j;
  37. crlf             = ^m^j;
  38. bell             = ^g;
  39. bs               = ^h;
  40. esc              = ^[;
  41. null             = '';          { Concatenation constants }
  42. space            = ' ';
  43. digits:charset   = ['.', '-', '0'..'9', 'e', 'E'];
  44. alphaset:charset = [' '..'}'];   { Printable characters }
  45.  
  46.  
  47. VAR
  48.  prompt                  : STRING[80];
  49.  ch                      : CHAR;
  50.  julian,year,month,day   : INTEGER;
  51.  dummy                   : STRING[1];
  52.  outfilename,filename    : STRING[14];
  53.  filvar,word             : TEXT;
  54.  i                       : BYTE;
  55.  stuff,data              : STRING[128];
  56.  result,page,count       : INTEGER;
  57.  
  58. PROCEDURE printer(which: prtype);
  59.  
  60. {------------------------------------------------------------------}
  61. {                                                                  }
  62. { this procedure allows for easy control of the major functions of }
  63. { the Okidata 92 printer. It is written in Turbo Pascal and should }
  64. { be included in your source program.  The following type          }
  65. { declaration must appear in your main program:                    }
  66. {                                                                  }
  67. { type                                                             }
  68. {                                                                  }
  69. {   prtype = (Cpi10,Cpi12,Cpi17,Wide,Reset,Correspond,DP,          }
  70. {             Enhanced,Emphacized,Normal,Form,SuperOn,             }
  71. {             SuperOff,SubOn,SubOff,UnderOn,UnderOff);             }
  72. {  Const   OKIDATA = TRUE;                                         }
  73. {                                                                  }
  74. {------------------------------------------------------------------}
  75.  
  76. VAR
  77.   c: STRING[2];
  78.  
  79. BEGIN
  80.   CASE which OF
  81.     cpi10      : c:= CHR(30);            { 10 char/inch   80/line }
  82.     cpi12      : c:= CHR(28);            { 12 char/inch   96/line }
  83.     cpi17      : c:= CHR(29);            { 17.1 char/inch 132/line}
  84.     wide       : c:= CHR(31);            { double wide characters }
  85.     RESET      : c:= CHR(24);            { reset to poweron values}
  86.     correspond : c:= CHR(27)+CHR(49);    { correspondence quality }
  87.     dp         : c:= CHR(27)+CHR(48);    { data processing qual.  }
  88.     enhanced   : c:= CHR(27)+CHR(72);    { enhanced printing      }
  89.     emphacized : c:= CHR(27)+CHR(84);    { emphacized printing    }
  90.     normal     : c:= CHR(27)+CHR(73);    { no enhanced/emphacized }
  91.     form       : c:= CHR(12);            { form feed              }
  92.     superon    : c:= CHR(27)+CHR(74);    { superscripting on      }
  93.     superoff   : c:= CHR(27)+CHR(75);    { superscripting off     }
  94.     subon      : c:= CHR(27)+CHR(76);    { subscripting on        }
  95.     suboff     : c:= CHR(27)+CHR(77);    { subscripting off       }
  96.     underon    : c:= CHR(27)+CHR(67);    { underlining on         }
  97.     underoff   : c:= CHR(27)+CHR(68);    { underlining off        }
  98.   END;   { case }
  99. IF ((okidata) OR (which = form)) THEN
  100.   WRITE(LST,c);                          { write command to printer}
  101. END;
  102.  
  103. PROCEDURE CLEARFRAME;
  104. VAR
  105.   i : INTEGER;
  106. BEGIN
  107.   FOR i := 20 DOWNTO 3  DO
  108.   BEGIN
  109.     GOTOXY(1,i + 1); CLREOL ;
  110.   END;
  111. END;
  112.  
  113. PROCEDURE upper_case(VAR strg : STR);
  114. {A+}
  115. BEGIN
  116.   INLINE ($2a/strg/$46/$04/$05/$ca/*+20/$23/$7e/$fe/$61/$da/*-9/
  117.           $fe/$7b/$d2/*-14/$d6/$20/$77/$c3/*-20);
  118. {A-}
  119. END;
  120.  
  121. PROCEDURE select(    prompt : str80;
  122.                      term   : charset;
  123.                  VAR tc     : CHAR    );
  124. VAR
  125.   ch : CHAR;
  126. BEGIN
  127.   GOTOXY(1,23); WRITE(prompt); CLREOL;
  128.   REPEAT
  129.     READ(KBD,ch);
  130.     tc := UPCASE(ch);
  131.     IF NOT (tc IN term) THEN
  132.       WRITE(^g);
  133.   UNTIL tc IN term;
  134.   WRITE(ch);
  135. END;
  136.  
  137. PROCEDURE help;
  138. BEGIN
  139.   GOTOXY(1,8);
  140.   WRITELN('Selecting ''1'' will process a Turbo Pascal program you have written.');
  141.   WRITELN('It will write the procedures and functions contained in that program');
  142.   WRITELN('to a file.');
  143.   WRITELN('Selecting ''2'' will allow you to list a file to the printer.');
  144.   WRITELN('Selecting ''3'' displays this file.');
  145.   WRITELN('Selecting ''4'' exits this program.');
  146.   select('Press <RETURN> to continue. ',[^m],ch);
  147.   CLEARFRAME;
  148. END;
  149.  
  150. PROCEDURE getln(VAR s:str80; okset:charset; maxlen:INTEGER);
  151. VAR ch:    CHAR;
  152.     stemp: str80;
  153.     len:   INTEGER;
  154.     first,
  155.     last:  BOOLEAN;
  156.     getset:charset;
  157.  
  158.   FUNCTION getchar(okset:charset):CHAR;
  159.   VAR OK:BOOLEAN; ch:CHAR;
  160.   BEGIN
  161.     REPEAT
  162.       READ(KBD,ch);
  163.       IF EOLN(KBD) THEN ch:=cr;
  164.       OK:=ch IN okset;
  165.       IF NOT OK
  166.         THEN WRITE(CON,bell)
  167.         ELSE IF ch IN alphaset THEN WRITE(CON,ch)
  168.     UNTIL OK;
  169.     getchar:=ch
  170.   END;  {getchar}
  171.  
  172. BEGIN
  173.   stemp:=null;
  174.   ch:=space;
  175.   REPEAT
  176.     len:=LENGTH(stemp);
  177.     first:=len=0;
  178.     last:=len=maxlen;
  179.     IF first THEN getset:=okset+[cr]
  180.       ELSE IF last THEN getset:=[cr,bs]
  181.       ELSE getset:=okset+[cr,bs];
  182.     ch:=getchar(getset);
  183.     IF ch=bs THEN
  184.       BEGIN
  185.         WRITE(bs,space,bs);
  186.         DELETE(stemp,len,1)
  187.       END
  188.     ELSE IF ch IN okset-[cr] THEN stemp:=stemp+ch
  189.   UNTIL ch=cr;
  190.   s:=stemp
  191. END;  {getln}
  192.  
  193. FUNCTION ival(VAR s:str80):INTEGER;
  194. VAR go: BOOLEAN; n:INTEGER;
  195. BEGIN
  196.   n:=0; go:=TRUE;
  197.   WHILE (s<>null) AND go DO
  198.     BEGIN
  199.       IF s[1] IN ['0'..'9'] THEN
  200.         n:=( n*10 + ORD(s[1])-ORD('0') ) MOD 3000
  201.       ELSE go:=FALSE;
  202.       DELETE(s,1,1)
  203.     END;
  204.   ival:=n
  205. END;  {ival}
  206.  
  207. PROCEDURE dtoj(day,month,year: INTEGER;VAR julian: INTEGER);
  208.   { Convert from a date to a Julian number -- January 1, 1900 = -32767 }
  209.   { Note that much care is taken to avoid problems with inaccurate bit representations inherent in the binary fractions
  210.     of the real numbers used as temporary variables.  Thus the seemingly unnecessary use of small fractional offsets
  211.     and int() functions }
  212.   BEGIN
  213.   IF (year=1900) AND (month<3)                   { Handle the first two months as a special case since the general }
  214.    THEN                                          {   algorithm used doesn't start until March 1, 1900 }
  215.     IF month=1
  216.      THEN
  217.       julian := day-$8000                        { Compiler won't accept -32768 as a valid integer, so use the hex form }
  218.      ELSE
  219.       julian := day-32737
  220.    ELSE
  221.     BEGIN
  222.     IF month>2
  223.      THEN
  224.       month := month-3
  225.      ELSE
  226.       BEGIN
  227.       month := month+9;
  228.       year := year-1
  229.       END;
  230.     year := year-1900;
  231.     julian := ROUND(-32709.0+day+INT(0.125+INT(1461.0*year+0.5)/4.0))+((153*month+2) DIV 5)
  232.     END
  233.   END;
  234.  
  235. PROCEDURE jtod(julian: INTEGER;VAR day,month,year: INTEGER);
  236.   { Convert from a Julian date to a calendar date }
  237.   { Note that much care is taken to avoid problems with inaccurate bit representations inherent in the binary fractions
  238.     of the real numbers used as temporary variables.  Thus the seemingly unnecessary use of small fractional offsets
  239.     and int() functions }
  240.   VAR temp: REAL;
  241.   BEGIN
  242.   temp := INT(32767.5+julian);                   { Convert 16 bit quantity into a real number }
  243.   IF temp<58.5
  244.    THEN
  245.     BEGIN                                        { The first two months of the twentieth century are handled as a special }
  246.     year := 1900;                                {   case of the general algorithm used which handles all of the rest }
  247.     IF temp<30.5
  248.      THEN
  249.       BEGIN
  250.       month := 1;
  251.       day := ROUND(temp+1.0)
  252.       END
  253.      ELSE
  254.       BEGIN
  255.       month := 2;
  256.       day := ROUND(temp-30.0)
  257.       END
  258.     END
  259.    ELSE
  260.     BEGIN
  261.     temp := INT(4.0*(temp-59.0)+3.5);
  262.     year := TRUNC(temp/1461.0+0.00034223);     { 0.00034223 is about one half of the reciprocal of 1461.0 }
  263.     day := SUCC(ROUND(temp-year*1461.0) DIV 4);
  264.     month := (5*day-3) DIV 153;
  265.     day := SUCC((5*day-3) MOD 153 DIV 5);
  266.     year := year+1900;
  267.     IF month<10
  268.      THEN
  269.       month := month+3
  270.      ELSE
  271.       BEGIN
  272.       month := month-9;
  273.       year := SUCC(year)
  274.       END
  275.     END
  276.   END;
  277.  
  278. FUNCTION dayofweek(julian: INTEGER): INTEGER;
  279.   { Return an integer representing the day of week for the date }
  280.   { Sunday = 0, etc. }
  281.   VAR temp: REAL;
  282.   BEGIN
  283.   temp := julian+32767.0;                        { Convert into a real temporary variable }
  284.   dayofweek := ROUND(FRAC((temp+1.0)/7.0)*7.0)   { Essentially this is a real number version of Julian mod 7 with }
  285.   END;                                           { an offset to make Sunday = 0 }
  286.  
  287. PROCEDURE writedate(julian: INTEGER);
  288.   { Write the date out to the console in long form , e.g. "Monday, September 10, 1984" }
  289.   CONST days: ARRAY[0..6] OF STRING[9]=('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
  290.         months: ARRAY[1..12] OF STRING[9] = ('January','February','March','April','May','June',
  291.                                              'July','August','September','October','November','December');
  292.   VAR day,month,year: INTEGER;
  293.   BEGIN
  294.   jtod(julian,day,month,year);                   { Convert into date form }
  295.   WRITELN(days[dayofweek(julian)],' ',months[month],' ',day,', ',year);
  296.   END;
  297.  
  298. PROCEDURE writedateprinter(julian: INTEGER);
  299.   { Write the date out to the printer in long form , e.g. "Monday, September 10, 1984" }
  300.   CONST days: ARRAY[0..6] OF STRING[9]=('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
  301.         months: ARRAY[1..12] OF STRING[9] = ('January','February','March','April','May','June',
  302.                                              'July','August','September','October','November','December');
  303.   VAR day,month,year: INTEGER;
  304.   BEGIN
  305.   jtod(julian,day,month,year);                   { Convert into date form }
  306.   WRITELN(LST,days[dayofweek(julian)],' ',months[month],' ',day,', ',year);
  307.   END;
  308.  
  309. FUNCTION tab(spaces : INTEGER) : str80;
  310. VAR
  311.   column : INTEGER;
  312.   temp   : str80;
  313. BEGIN
  314.   temp :='';
  315.   FOR column := 1 TO spaces DO
  316.   BEGIN
  317.     temp := temp + ' ';
  318.     tab := temp;
  319.   END;
  320. END;
  321.  
  322. FUNCTION file_exists(fname : name) : BOOLEAN;
  323. VAR
  324.   ffile : FILE;
  325. BEGIN
  326.   ASSIGN(ffile,fname);
  327.   {$I-}
  328.   RESET(ffile);
  329.   {$I+}
  330.   file_exists := (IORESULT = 0)
  331. END;
  332.  
  333. PROCEDURE blast; (* CLEARSCREEN *)
  334. BEGIN
  335.   {A+}
  336.   INLINE ($0e/$02/$1e/$1a/$c3/$05/$00/$00);
  337.   {A-}
  338. END;
  339.  
  340. PROCEDURE put_up_message;
  341.  
  342. BEGIN
  343.   GOTOXY(1,4);  WRITELN('Procedure & Function Lister   By : William L. Mabee, CRNA');
  344.   WRITELN('This program will create a file containing a list of procedures');
  345.   WRITELN('and functions from TURBO PASCAL programs you have written. Your');
  346.   WRITELN('first prompt will be for the name of the file you want these');
  347.   WRITELN('procedures and functions written to.');
  348.   WRITELN('Your second prompt will be for the name of the program you');
  349.   WRITELN('have written and wish to obtain a list of procedures and');
  350.   WRITELN('functions.');
  351.   WRITELN('You may continue to read in programs you wish to obtain a');
  352.   WRITELN('listing of functions and procedures from until you enter');
  353.   WRITELN('a carriage return when prompted for the name of the file to');
  354.   WRITELN('process.');
  355.   select('Press <RETURN> to continue. ',[^m],ch);
  356.   CLEARFRAME;
  357. END;
  358.  
  359. PROCEDURE getoutfilename(VAR outfilename : str14);
  360. LABEL done;
  361. BEGIN
  362.   REPEAT
  363.     GOTOXY(1,10); WRITE('Enter a carriage return to exit this procedure.');
  364.     GOTOXY(1,12); WRITE('This file will contain a list of the procedures and functions.');
  365.     GOTOXY(1,14); WRITE('Enter Name of file to Create  : '); READ(outfilename);
  366.     IF outfilename = '' THEN GOTO done;
  367.     IF file_exists(outfilename) = TRUE THEN
  368.       BEGIN
  369.         WRITE(^g);
  370.         GOTOXY(1,18); WRITE('File Exists');
  371.         DELAY(2000); GOTOXY(1,18); CLREOL;
  372.         GOTOXY(32,14); CLREOL;
  373.       END;
  374.   UNTIL file_exists(outfilename) = FALSE;
  375.   ASSIGN(word,outfilename);
  376.   REWRITE(word);
  377.   done :
  378.   CLEARFRAME;
  379. END;
  380.  
  381. PROCEDURE getfilename(VAR filename : str14);
  382. LABEL done;
  383. BEGIN
  384.   count := 1;
  385.   REPEAT
  386.     CLEARFRAME;
  387.     GOTOXY(1,10); WRITE('Enter a carriage return to exit this procedure.');
  388.     GOTOXY(1,12); WRITE('Enter Name of File to Process : ');
  389.     REPEAT
  390.       READ(filename);
  391.       IF filename = '' THEN GOTO done;
  392.       IF file_exists(filename)= FALSE THEN
  393.         BEGIN
  394.           GOTOXY(33,12);
  395.           CLREOL;
  396.           WRITE(^g);
  397.         END;
  398.     UNTIL file_exists(filename) = TRUE;
  399.     ASSIGN(filvar,filename);
  400.     RESET(filvar);
  401.     IF count = 1 THEN WRITELN(word,dash);
  402.       BEGIN
  403.         WRITELN(word,'(* The file ',filename,' contains the following : ',tab(38-LENGTH(filename)),'*)');
  404.         CLEARFRAME;
  405.         GOTOXY(1,10); WRITE('Reading from file : ',filename);
  406.         GOTOXY(1,12); WRITE('Writing to file   : ',outfilename);
  407.         WRITELN(word,open);
  408.         WHILE NOT EOF(filvar) DO
  409.         BEGIN
  410.           READLN(filvar,data);
  411.           upper_case(data);
  412.           IF (COPY(data,1,9) = 'PROCEDURE') OR (COPY(data,1,8) = 'FUNCTION') OR
  413.           (COPY(data,1,7) = 'OVERLAY') OR (COPY(data,1,7) = 'PROGRAM') OR
  414.           (COPY(data,1,8) = 'EXTERNAL') THEN
  415.           WRITELN(word,'(* ',data,tab(72-LENGTH(data)),' *)');
  416.         END;
  417.        WRITELN(word,open);
  418.        WRITELN(word,dash);
  419.        count := count + 1;
  420.        IF NOT EOF(filvar) THEN WRITELN(word,open);
  421.     END;
  422.   UNTIL filename = '';
  423.   done :
  424.   CLOSE(word);
  425.   CLEARFRAME;
  426.   IF count > 1 THEN CLOSE(filvar);
  427.   IF count < 2 THEN ERASE(word);
  428. END;
  429.  
  430. PROCEDURE print_it_out;
  431.  
  432. LABEL done;
  433. BEGIN
  434.   CLEARFRAME;
  435.   page := 1;
  436.   count := 1;
  437.   REPEAT
  438.     GOTOXY(1,12); WRITE('What is the name of the file you wish to print ');
  439.     READ(filename);
  440.     IF filename = '' THEN GOTO done;
  441.   UNTIL file_exists(filename) = TRUE;
  442.       BEGIN
  443.         REPEAT
  444.           CLEARFRAME;
  445.           GOTOXY(1,6);  WRITE('Enter numeric values for the date prompts.');
  446.           GOTOXY(1,8);  WRITE('Day    : '); getln(prompt,digits,2);
  447.           VAL(prompt,day,result);
  448.           GOTOXY(1,10); WRITE('Month  : '); getln(prompt,digits,2);
  449.           VAL(prompt,month,result);
  450.           GOTOXY(1,12); WRITE('Year   : 19'); getln(prompt,digits,2);
  451.           VAL(prompt,year,result);
  452.           year := year + 1900;
  453.           dtoj(day,month,year,julian);
  454.           GOTOXY(1,14);
  455.           writedate(julian);
  456.           select('Is this the current date (Y/N) ',['Y','N'],ch);
  457.         UNTIL ch = 'Y';
  458.         ASSIGN(filvar,filename);
  459.         RESET(filvar);
  460.         printer(cpi17);
  461.         WHILE NOT EOF(filvar) DO
  462.         BEGIN
  463.           IF count = 1 THEN
  464.             BEGIN
  465.               WRITELN(LST,'');
  466.               WRITE(LST,'Listing of file ',outfilename,'   Page # ',page,'  ');
  467.               writedateprinter(julian);
  468.               WRITELN(LST,'');
  469.             END;
  470.           READLN(filvar,data);
  471.           WRITELN(LST,data);
  472.           count := count + 1;
  473.           IF count = 50 THEN
  474.             BEGIN
  475.               page := page + 1;
  476.               count := 1;
  477.               printer(form);
  478.             END;
  479.         END;
  480.         IF count <> 1 THEN printer(form);
  481.       END;
  482.       done :
  483.       CLOSE(filvar);
  484.       printer(RESET);
  485.       CLEARFRAME;
  486. END;
  487.  
  488. BEGIN (* Main *)
  489.   blast;
  490.   GOTOXY(18,1); WRITE('TURBO PASCAL UTILITY : W. MABEE Ver 2.0');
  491.   put_up_message;
  492.   outfilename := '';
  493.   count := 1;
  494.   REPEAT
  495.     start :
  496.     select('1.) Process New File, 2.) Print existing file, 3.) Help, 4.) Quit ',['1','2','3','4'],ch);
  497.     CASE ch OF
  498.       '1' : BEGIN
  499.               getoutfilename(outfilename);
  500.               IF outfilename = '' THEN GOTO start;
  501.               getfilename(filename);
  502.             END;
  503.       '2' : print_it_out;
  504.       '3' : help;
  505.       '4' : GOTO escape;
  506.     END; (* Case *)
  507.   UNTIL ch = '3';
  508.   escape :
  509.   CLOSE(word);
  510.   CLOSE(filvar);
  511.   blast;
  512. END.
  513.