home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol028 / waduzit.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  7KB  |  312 lines
  1. {$C-,M-,F-}{ PASCAL/Z COMPILER OPTIONS }
  2. PROGRAM WADUZITDO;
  3. {
  4. +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  5. + PROGRAM TITLE:    What Does It Do?        +
  6. +                            +
  7. + WRITTEN BY:        Larry Kheriaty, Computer Center +
  8. +            Western Washington Univ.    +
  9. +            Bellingham, Wa. 98225        +
  10. +            BYTE MAG, Sept 1978        +
  11. +                            +
  12. + SUMMARY:                        +
  13. + A minimal PILOT interpreter.    A sample of what can be +
  14. + done with the high level language Pascal. Commands    +
  15. + will be found in the file WADUZIT.DOC.        +
  16. +                            +
  17. + Modification record:                    +
  18. +    1.1   -August 1979 Entered by Ray Penley        +
  19. +        program does not work as originally written.+
  20. +    1.2   -added EndOfString marker (EOS)        +
  21. +          and EndOfFile marker (EOFS)        +
  22. +        added DEBUG FLAG; procedure PAD;        +
  23. +        rewrote PROCEDURE LIST            +
  24. +        program still not working.            +
  25. +    1.3   -April 1, 1981 - finally got program to work!+
  26. +        rewrote LIST; some mods to EXECUTE;     +
  27. +        added getc(); putc(); readchar(); advance;    +
  28. +        added KEYIN(); signon header & prompt.    +
  29. +    1.4   -April 3, 1981 - Modified so that all lines    +
  30. +        are "linelength" characters long.  This    +
  31. +        allows a cleaner line insert and delete.    +
  32. +        added procedure debug;/deleted advance;    +
  33. +                            +
  34. +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  35. }
  36.  
  37. LABEL    1;        { Program termination on ctrl-e     }
  38.  
  39. CONST
  40.   prompt = '>';
  41.   CTRLD  = 4;        { control-D will display the whole     }
  42.             { memory buffer.             }
  43.   CTRLE  = 5;        { assign control-E as program terminator }
  44.   lines  = 50;        { total # of lines per program         }
  45.   linelength = 64 + 1;    { # chars/line plus one for EOS marker     }
  46.   BUFSIZE =        { total # of chars =             }
  47.      lines*linelength+1;{    linelength times (# of lines) + 1     }
  48.  
  49. VAR
  50.   tcount,        { line counter }
  51.   ppos,         { present position location }
  52.   lpos    : INTEGER;    { last position location    }
  53.  
  54.   BACKSPACE,        { backspace character  }
  55.   bell,         { terminal bell char   }
  56.   EOS,            { End of string marker }
  57.   EOFS,         { End of file marker   }
  58.   null,         { null character       }
  59.   lastchar,        { last character       }
  60.   FLAG,         { match flag           }
  61.   pchar : CHAR;     { current character    }
  62.  
  63.   membuffer : ARRAY [1..BUFSIZE] OF CHAR;{ the working area in memory }
  64.  
  65.   listing,        { Listing to console flag }
  66.   xeof,         { End of file flag }
  67.   xeoln : BOOLEAN;    { End of line flag }
  68.  
  69.  
  70.  
  71. PROCEDURE KEYIN(VAR ch: char); EXTERNAL;
  72. { Direct keyboard input of a single character }
  73.  
  74.  
  75. Procedure getc(VAR ch: char);
  76. { Read single character from the keyboard/ with echo }
  77. begin 
  78.   KEYIN(ch);Write(ch);
  79.   If ORD(ch)=13 then ch := EOS;
  80.   xeoln := ( ch=EOS );
  81. end;
  82.  
  83.  
  84. Procedure putc(ch: char);
  85. { Write out a single character to the output device }
  86. begin
  87.   if ( ch=EOS ) then
  88.     writeln
  89.   else
  90.     write(ch);
  91. end;
  92.  
  93.  
  94. Procedure Restart;
  95. begin
  96.   ppos := 1;
  97.   tcount := 0;
  98.   writeln('Ready');
  99.   putc(prompt);
  100. end;
  101.  
  102.  
  103. PROCEDURE INITIALIZE;
  104. BEGIN
  105.   BACKSPACE := CHR(8);
  106.   bell := CHR(7);
  107.   EOS := '|';        { end of string character }
  108.   EOFS := CHR(127);    { end of file character   }
  109.   null := CHR(0);
  110.   listing := false;
  111.   xeof := true;     { must be end of file since buffer is empty }
  112.   xeoln := false;
  113.  
  114.   { initialize the entire input buffer into lines }
  115.   ppos := 0;
  116.   repeat
  117.     ppos := ppos + 1;
  118.     if ( ppos MOD linelength=0 ) then
  119.        membuffer[ppos] := EOS        { end of string }
  120.     else
  121.        membuffer[ppos] := null;
  122.   until ( ppos=bufsize );
  123.   membuffer[ppos] := EOFS;        { end of file }
  124. END;
  125.  
  126.  
  127. Procedure Readchar(var ch: char);
  128. { Reads a single character from the input buffer }
  129. begin
  130.   ch := membuffer[ppos];
  131.   ppos := ppos + 1;
  132.   xeof := ( ch=EOFS );
  133.   xeoln := ( ch=EOS );
  134. end;
  135.  
  136.  
  137. Procedure push(ch: CHAR);
  138. begin
  139.   membuffer[ppos] := ch;
  140.   ppos := ppos +1;
  141. end;
  142.  
  143.  
  144. PROCEDURE LIST;
  145. BEGIN
  146.   Readchar(pchar);
  147.   if ( listing ) then
  148.     begin tcount := tcount + 1;
  149.       write(tcount:3,':  ');
  150.     end;
  151.   while not (xeof or xeoln) do
  152.     begin if ( pchar<>null ) then putc(pchar);
  153.       Readchar(pchar);
  154.     end;
  155.   putc(EOS);
  156. END;
  157.  
  158.  
  159. PROCEDURE PAD;
  160. { Pads a line by filling with nulls }
  161. BEGIN
  162.   while ( ppos MOD linelength<>0 ) do push(null);
  163.   push(EOS);
  164. END;
  165.  
  166.  
  167. PROCEDURE EXECUTE;
  168. VAR    i: INTEGER;
  169.     DONE : BOOLEAN;
  170. BEGIN
  171.   ppos := 1;        { * execution always starts here * }
  172.   DONE := FALSE;
  173.   REPEAT
  174.     pchar := membuffer[ppos] ;
  175.     IF (pchar < '*') THEN pchar := '*';
  176.     CASE pchar OF
  177.  
  178.     '*':    { * program marker - jump destination * }
  179.         ppos := ppos + 1;
  180.  
  181.     'Y','N':
  182.         { * YT:text  *    NT:text  *  YJ:n  *  NJ:n  * etc.  * }
  183.         IF pchar=FLAG THEN
  184.           ppos := ppos+1
  185.         ELSE
  186.           repeat
  187.             Readchar(pchar);
  188.           until ( xeof ) or ( xeoln );
  189.  
  190.     'A':    begin  { *    A:    * }
  191.           lpos := ppos;
  192.           getc(pchar);
  193.           lastchar := pchar;
  194.           putc(EOS);
  195.           ppos := ppos + 2
  196.         end;
  197.  
  198.     'M':    BEGIN    { *    M:x         * }
  199.           IF ( lastchar=membuffer[ppos+2] ) then
  200.              FLAG := 'Y'
  201.           ELSE
  202.              FLAG := 'N';
  203.           ppos := ppos+3
  204.         END;
  205.  
  206.     'J':    { *   J:n    * }
  207.         IF ( membuffer[ppos+2]='0' ) then
  208.           ppos := lpos
  209.         ELSE
  210.           begin { CONVERT ASCII CHAR TO NUMBER }
  211.             i := ORD(membuffer[ppos+2])-48;
  212.             REPEAT
  213.               Readchar(pchar);
  214.               IF ( pchar='*' ) THEN i := i - 1
  215.             UNTIL ( i=0 ) OR ( xeof );
  216.           END;
  217.  
  218.     'T':    BEGIN    { *   T:text    * }
  219.           ppos := ppos + 2;
  220.           LIST
  221.         END;
  222.  
  223.     'S':    BEGIN    { *   S:     * }
  224.           DONE := TRUE;
  225.         END
  226.  
  227.     ELSE:    LIST;
  228.  
  229.     END;(* case *)
  230.   Until ( done ) or (membuffer[ppos]=EOFS);
  231. END;
  232.  
  233.  
  234. Procedure debug;
  235. var    ch: char;
  236. begin
  237.   ppos := 1;    { * start at first char in the memory buffer * }
  238.   repeat
  239.      repeat
  240.     Readchar(ch);
  241.     if ( ch=null ) then putc('.')
  242.     else putc(ch);
  243.      until (ch=eos) or (ch=eofs);
  244.   until (ch=eofs);
  245.   writeln;
  246.   Restart;
  247. end;
  248.  
  249.  
  250. Procedure DoCommand(comchar: char);
  251. begin
  252.   putc(EOS);
  253.   CASE comchar of
  254.  
  255.     '/':  begin listing := true;
  256.         LIST;
  257.         listing := false;
  258.         putc(prompt);
  259.       end;
  260.  
  261.     '\':  Restart;
  262.  
  263.     '$':  begin EXECUTE;
  264.         Restart;
  265.       end;
  266.  
  267.     '%':  begin PAD;
  268.         Restart;
  269.       end;
  270.   END{of CASE};
  271. end;
  272.  
  273.  
  274.  
  275. BEGIN    (* MAIN PROGRAM *)
  276.   WRITELN(' ':20, 'WHAT DOES IT DO?');
  277.   WRITELN(' ':20, 'by Larry Kheriaty');
  278.   WRITELN(' ':20, 'this version by Ray Penley');
  279.   WRITELN;WRITELN;
  280.   INITIALIZE;
  281.   restart;
  282.   getc(pchar);
  283.   While true do { start infinite loop }
  284.     BEGIN
  285.       if ord(pchar)=CTRLE then {EXIT}
  286.      goto 1
  287.       else if ord(pchar)=CTRLD then
  288.      Debug
  289.       else IF ( pchar=BACKSPACE ) and ( ppos>1 ) then
  290.     ppos := ppos - 1
  291.       else
  292.     begin if pchar IN ['/','\','$','%'] then
  293.         DoCommand(pchar)
  294.           else
  295.         begin IF ( pchar<>eos ) then
  296.             push(pchar)     { * store present char * }
  297.               else
  298.             begin PAD;
  299.                   putc(EOS);
  300.                   putc(prompt);
  301.             end;
  302.         end;
  303.     end;
  304.       if ( ppos>=bufsize ) then
  305.      begin writeln(bell, '+++MEMORY FULL');
  306.            restart;
  307.      end;
  308.       getc(pchar);
  309.     END;
  310. 1:WRITELN;
  311. END.
  312.