--::::::::::
--cli.cmm
--::::::::::
Comments on Porting
Command Language Interpreter (CLI)
by WIS JPMO
to DEC Ada
Tool 34
August 2, 1985
COMPILATION
-----------
A VMS command file was created from the ordered list of compilation
units provided in CLISRC.DIS.
We were able to recompile the Command Language Interpreter with only
minor changes in two files. Errors occured because the generic
instantiation of package INTEGER_IO was needed, but had been
commented out of the code. This comment notation was removed.
Additionally, the parameter "C" in the procedure GETC had to be
changed to mode "in out" from mode "out", so that a necessary assignment
could be made to "C".
EXECUTION
---------
We were able to link CLI_2 without any problems. Although no
Users Manual was provided, the code stated that the Command
Language Interpreter (CLI) implements the tools found in
chapters one and two of "Software Tools in Pascal" by Brian
W. Kernighan and P. J. Plauger. The following commands were
able to be executed by the Command Language Interpreter:
copy detab expand
charcount entab translit
linecount overstrike quit
wordcount compress
Most of the commands read subsequent text from the terminal
modifying it in one way or another. The commands we tried
worked and would exit as expected, but when the CLI tried to
read the next command the end-of-file condition would not be
cleared and the CLI would abort with an unhandled exception
"END_ERROR".
COMMENT
-------
The CLI is not a generalized command language interpreter. Rather
it provides a framework upon which to build a more general CLI.
--::::::::::
--cli.dis
--::::::::::
[whitaker.tools.cli]chpt1.txt
[whitaker.tools.cli]chpt2.txt
[whitaker.tools.cli]cli2.txt
--::::::::::
--cli.pro
--::::::::::
-------- SIMTEL20 Ada Software Repository Prologue ------------
-- -*
-- Unit name : Command Language Interpreter (CLI)
-- Version : 1.0
-- Author : WIS JPMO
-- : Washington, D.C. 20330
-- : Contact: Lt. Colonel Falgiano
-- : ESD/SCW
-- : Hanscom AFB, MA 01731
-- DDN Address :
-- Copyright : (c) 1985
-- Date created : 1985
-- Release date : 1985
-- Last update : 1985
-- Machine/System Compiled/Run on:
-- -*
---------------------------------------------------------------
-- -*
-- Keywords :
----------------:
--
-- Abstract : The Command Language Interpreter (CLI)
----------------: implements the tools found in chapters
----------------: one and two of "Software Tools in
----------------: Pascal" by Brian W. Kernighan and P.J.
----------------: Plauger. The commands available for
----------------: execution are: copy, charcount, linecount,
----------------: wordcount, detab, entab, overstrike,
----------------: compress, expand, translit and quit.
----------------: Most of the commands read subsequent
----------------: text from the terminal modifying it in
----------------: one way or another.
----------------:
----------------: This tool was developed as a precursor for
----------------: the WMCCS Information System (WIS). An
----------------: executable version of the tool has been
----------------: demonstrated. This source code has sub-
----------------: sequently been recompiled but has not under-
----------------: gone extensive testing.
----------------:
-- -*
------------------ Revision history ---------------------------
-- -*
-- DATE VERSION AUTHOR HISTORY
-- 1985 1.0 WIS JPMO Initial Release
-- -*
------------------ Distribution and Copyright -----------------
-- -*
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
-- software released to the Public Domain is not subject
-- to copyright protection).
-- Restrictions on use or distribution: NONE
-- -*
----------------- Disclaimer ----------------------------------
-- -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
--
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered. The user is advised to
-- test the software thoroughly before relying on it. The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
-- -*
----------------- END-PROLOGUE -------------------------------
--::::::::::
--cli.src
--::::::::::
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--chpt1.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
package CHAPTER_1 is
-- From Kernighan and Plauger's "Software Tools in Pascal" Addison-Wesley
use TEXT_IO;
TAB : constant CHARACTER := ASCII.HT;
LF : constant CHARACTER := ASCII.LF;
NEWLINE : constant CHARACTER := ASCII.CR;
ENDFILE : constant CHARACTER := ASCII.FS;
BLANK : constant CHARACTER := ' ';
MAXLINE : constant INTEGER := 250;
TABSPACE : constant INTEGER := 4;
type TABTYPE is array(INTEGER range 1..MAXLINE) of BOOLEAN;
TABSTOPS : TABTYPE;
procedure GETC(C : out CHARACTER);
procedure COPY;
procedure CHARCOUNT;
procedure LINECOUNT;
procedure WORDCOUNT;
function TABPOS(COL : INTEGER; TABSTOPS : TABTYPE) return BOOLEAN;
procedure SETTABS(TABSTOPS : out TABTYPE);
procedure DETAB;
end CHAPTER_1;
with TEXT_IO;
package body CHAPTER_1 is
-- Comments mostly point out differences from Pascal version
-- package INTEGER_IO is new TEXT_IO.INTEGER_IO(INTEGER);
use TEXT_IO;
use INTEGER_IO;
procedure GETC(C : out CHARACTER) is
-- Different from the SWT getc which is a function with side effect
-- This can read a ASCII.FS from the keyboard for a file terminator
-- Or use an END_ERROR off a file or tape
begin
GET(C);
if C = ENDFILE then
raise END_ERROR;
end if;
end GETC;
procedure COPY is
-- 1.1 copy input characters to output
-- This has the major modification to the style of Software Tools
-- That style may have been required by limitations of other languages
-- Rather than the unusual getc function with side effects
-- we will use a more conventional Ada construct
-- End of file will be handled as in Ada rather than as a special character
-- so type CHARACTER can be used
-- When an explicit End of file character is needed ASCII.FS will be used
C : CHARACTER;
begin
loop
GETC(C);
PUT(C); -- May have to turn off local echo to make sense
end loop;
exception
when END_ERROR =>
null; -- When system EOF finish and exit
when others =>
null;
end COPY;
procedure CHARCOUNT is
-- 1.2 count characters in standard input
C : CHARACTER;
NC : INTEGER := 0; -- Can initialize here in Ada
begin
loop
GETC(C);
NC := NC + 1;
end loop;
NEW_LINE;
PUT("NUMBER OF CHARACTERS = ");
PUT(NC); -- Ada PUT distinguishes type
NEW_LINE; -- Ada has explicit procedure
exception
when END_ERROR =>
NEW_LINE;
PUT("NUMBER OF CHARACTERS = ");
PUT(NC);
NEW_LINE;
end CHARCOUNT;
procedure LINECOUNT is
-- 1.3 count lines in standard input
C : CHARACTER;
NL : INTEGER := 0;
begin
loop
GETC(C);
if C = NEWLINE then -- Looks for explicit end of line
NL := NL + 1;
end if;
end loop;
NEW_LINE;
PUT("NUMBER OF LINES = ");
PUT(NL);
NEW_LINE;
exception
when END_ERROR =>
NEW_LINE;
PUT("NUMBER OF LINES = ");
PUT(NL); -- An unterminated fragment is not counted
NEW_LINE;
end LINECOUNT;
procedure WORDCOUNT is
-- 1.4 count lines in standard input
C : CHARACTER;
WC : INTEGER := 0;
INWORD : BOOLEAN := FALSE; -- BOOLEAN rather than integer
begin
loop
GETC(C);
if C = BLANK or C = NEWLINE or C = TAB or C = LF then
INWORD := FALSE; -- We also worry about line feed
else
if INWORD = FALSE then
INWORD := TRUE;
WC := WC + 1;
end if;
end if;
end loop;
NEW_LINE;
PUT("NUMBER OF WORDS = ");
PUT(WC);
NEW_LINE;
exception
when END_ERROR =>
NEW_LINE;
PUT("NUMBER OF WORDS = ");
PUT(WC);
NEW_LINE;
end WORDCOUNT;
procedure SETTABS(TABSTOPS : out TABTYPE) is
-- 1.5 set initial tab stops
begin
for I in 1..MAXLINE loop
if I mod TABSPACE = 1 then
TABSTOPS(I) := TRUE;
else
TABSTOPS(I) := FALSE;
end if;
end loop;
end SETTABS;
function TABPOS(COL : INTEGER; TABSTOPS : TABTYPE) return BOOLEAN is
-- 1.5 return true if col is a tab stop
begin
if COL > MAXLINE then
return TRUE;
else
return TABSTOPS(COL);
end if;
end TABPOS;
procedure DETAB is
-- 1.5 convert tabs to equivalent number of blanks
C : CHARACTER;
COL : INTEGER := 1;
begin
SETTABS(TABSTOPS);
loop
GETC(C);
if C = TAB then
loop
PUT(BLANK);
COL := COL + 1;
exit when TABPOS(COL, TABSTOPS) = TRUE;
end loop;
elsif C = NEWLINE then
PUT(NEWLINE);
COL := 1;
else
PUT(C);
if C /= LF then
COL := COL + 1;
end if;
end if;
end loop;
PUT(ENDFILE); -- If that is how we got here
exception
when END_ERROR =>
null; -- If we got out by sensing EOF
end DETAB;
begin
SET_INPUT(STANDARD_INPUT);
end CHAPTER_1;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--chpt2.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CHAPTER_1; use CHAPTER_1;
package CHAPTER_2 is
BACKSPACE : constant CHARACTER := ASCII.BS;
WARNING : constant CHARACTER := ASCII.TILDE;
ENDLINE : constant CHARACTER := NEWLINE;
ENDSTR : constant CHARACTER := ASCII.GS; -- CTL-]
ESCAPE : constant CHARACTER := '@';
DASH : constant CHARACTER := '-';
NEGATE : constant CHARACTER := '^';
MAXSTR : constant INTEGER := MAXLINE;
MAXSET : constant INTEGER := MAXSTR;
MAXARG : constant INTEGER := 12;
ARGUMENTS : array(1..MAXARG) of STRING(1..MAXSTR);
NUMBER_OF_ARGUMENTS : INTEGER := 0;
GETARG_OK : BOOLEAN := FALSE;
ADDSTR_OK : BOOLEAN := FALSE;
MAKESET_OK : BOOLEAN := FALSE;
ESCAPED_CHAR : CHARACTER;
ERROR_ERROR : exception;
GETARG_ERROR : exception;
ADDSTR_ERROR : exception;
MAKESET_ERROR : exception;
TRANSLIT_ERROR : exception;
procedure ERROR(ERROR_MESSAGE : STRING);
procedure ENTAB;
function MAX(X, Y : INTEGER) return INTEGER;
procedure OVERSTRIKE;
function MIN(X, Y : INTEGER) return INTEGER;
procedure COMPRESS;
function ISUPPER(C : CHARACTER) return BOOLEAN;
procedure EXPAND;
procedure CONVERT_ESCAPED(S : in STRING;
I : in out INTEGER;
ESCAPED_CHAR : out CHARACTER);
procedure GETARG(N : in INTEGER;
ARGSTR : out STRING;
MAX_OF : in INTEGER);
function LENGTH(S : STRING) return INTEGER;
procedure ADDSTR(C : in CHARACTER;
OUTSET : in out STRING;
J : in out INTEGER;
MAX_OF : in INTEGER);
procedure DODASH(DELIM : in CHARACTER;
SRC : in STRING;
I : in out INTEGER;
DEST : in out STRING;
J : in out INTEGER;
MAX_OF : in INTEGER);
procedure TRANSLIT;
end CHAPTER_2;
with TEXT_IO;
with CHAPTER_1; use CHAPTER_1;
package body CHAPTER_2 is
-- package INTEGER_IO is new TEXT_IO.INTEGER_IO(INTEGER);
use TEXT_IO;
use INTEGER_IO;
procedure ERROR(ERROR_MESSAGE : STRING) is
begin
PUT(ERROR_MESSAGE);
raise ERROR_ERROR;
end ERROR;
procedure ENTAB is
-- 2.1 replace blanks by tabs and blanks
type TABTYPE is array (INTEGER range 1..MAXLINE) of BOOLEAN;
C : CHARACTER;
COL, NEWCOL : INTEGER := 1;
begin
SETTABS(TABSTOPS);
loop
NEWCOL := COL;
loop
GETC(C);
exit when C /= BLANK;
NEWCOL := NEWCOL + 1;
if TABPOS(NEWCOL, TABSTOPS) then
PUT(TAB);
COL := NEWCOL;
end if;
end loop;
while COL < NEWCOL loop
PUT(BLANK);
COL := COL + 1;
end loop;
if C /= ENDFILE then
PUT(C);
if C = NEWLINE then
COL := 1;
else
COL := COL + 1;
end if;
end if;
exit when C = ENDFILE;
end loop;
exception
when END_ERROR =>
null; -- When system EOF finish and exit
when others =>
null;
end ENTAB;
function MAX(X, Y : INTEGER) return INTEGER is
-- 2.2 compute maximum of two integers
begin
if X > Y then
return X;
else
return Y;
end if;
end MAX;
procedure OVERSTRIKE is
-- 2.2 convert into multiple lines
SKIP : constant CHARACTER := BLANK;
NOSKIP : constant CHARACTER := '+';
C : CHARACTER;
COL, NEWCOL : INTEGER := 1;
I : INTEGER;
begin
loop
NEWCOL := COL;
loop -- eat backspace
GETC(C);
exit when C /= BACKSPACE;
NEWCOL := MAX(NEWCOL - 1, 1);
end loop;
if NEWCOL < COL then
NEW_LINE;
PUT(NOSKIP); -- start overstrike line
for I in 1..NEWCOL-1 loop
PUT(BLANK);
end loop;
COL := NEWCOL;
elsif COL = 1 and C /= ENDFILE then
PUT(SKIP); -- normal line
end if;
if C /= ENDFILE then
PUT(C);
if C = NEWLINE then
COL := 1;
else
COL := COL + 1;
end if;
end if;
exit when C = ENDFILE;
end loop;
exception
when END_ERROR =>
null; -- When system EOF finish and exit
when others =>
null;
end OVERSTRIKE;
function MIN(X, Y : INTEGER) return INTEGER is
-- 2.3 compute minimum of two integers
begin
if X < Y then
return X;
else
return Y;
end if;
end MIN;
procedure PUTREP(N : in INTEGER; C : in CHARACTER) is
-- 2.3 put out representation of run of n 'C's
MAXREP : constant INTEGER := 26; -- assumimg 'A'..'Z'
THRESH : constant INTEGER := 4;
M : INTEGER;
begin
M := N;
while M >= THRESH or (C = WARNING and M > 0) loop
PUT(WARNING);
PUT(CHARACTER'VAL(MIN(N, MAXREP) - 1 + CHARACTER'POS('A')));
PUT(C);
M := M - MAXREP;
end loop;
for I in REVERSE 1..M loop
PUT(C);
end loop;
end PUTREP;
procedure COMPRESS is
-- 2.3 compress standard input
C, LASTC : CHARACTER;
N : INTEGER := 1;
begin
GETC(LASTC);
while LASTC /= ENDFILE loop
GETC(C);
if C = ENDFILE then
if N > 1 or LASTC = WARNING then
PUTREP(N, LASTC);
N := 1;
else
PUT(LASTC);
end if;
elsif C = LASTC then
N := N + 1;
elsif N > 1 or LASTC = WARNING then
PUTREP(N, LASTC);
N := 1;
else
PUT(LASTC);
end if;
LASTC := C;
end loop;
exception
when END_ERROR =>
null; -- When system EOF finish and exit
if N > 1 or LASTC = WARNING then
PUTREP(N, LASTC);
N := 1;
else
PUT(LASTC);
end if;
when others =>
null;
end COMPRESS;
function ISUPPER(C : CHARACTER) return BOOLEAN is
-- 2.4 true if C is upper case letter
begin
return C in 'A'..'Z';
end ISUPPER;
procedure EXPAND is
-- 2.4 uncompress standard input
C : CHARACTER;
N : INTEGER;
begin
loop
GETC(C);
exit when C = ENDFILE;
if C /= WARNING then
PUT(C);
else
GET(C);
if ISUPPER(C) then
N := CHARACTER'POS(C) - CHARACTER'POS('A') + 1;
GET(C);
if C /= ENDFILE then
for I in reverse 1..N loop
PUT(C);
end loop;
else
PUT(WARNING);
PUT(CHARACTER'VAL(N - 1 + CHARACTER'POS('A')));
end if;
else
PUT(WARNING);
if C /= ENDFILE then
PUT(C);
end if;
end if;
end if;
end loop;
exception
when END_ERROR =>
null; -- When system EOF finish and exit
PUT(ENDFILE); -- I think it needs this one
when others =>
null;
end EXPAND;
procedure GETARG(N : in INTEGER;
ARGSTR : out STRING;
MAX_OF : in INTEGER) is
begin
if N > NUMBER_OF_ARGUMENTS then
--GETARG_OK := FALSE; --########################################
ARGSTR(1) := ENDSTR;
else
--GETARG_OK := TRUE;
ARGSTR := ARGUMENTS(N);
end if;
return;
end GETARG;
function LENGTH(S : STRING) return INTEGER is
-- 2.5 compute length of string
-- A bit different from the Pascal in initialization and return lines
N : INTEGER := 0;
begin
for I in 1..MAXSTR loop
exit when S(I) = ENDSTR;
N := N + 1;
end loop;
return N;
end LENGTH;
procedure ECHO is
-- 2.5 echo command line arguments to output
I : INTEGER := 1;
ARGSTR : STRING(1..MAXSTR);
begin
loop
GETARG(I, ARGSTR, MAXSTR);
if I > 1 then
PUT(BLANK);
end if;
for J in 1..LENGTH(ARGSTR) loop
PUT(ARGSTR(J));
end loop;
I := I + 1;
end loop;
exception
when GETARG_ERROR =>
if I > 1 then
NEW_LINE;
end if;
end ECHO;
procedure CONVERT_ESCAPED(S : in STRING;
I : in out INTEGER;
ESCAPED_CHAR : out CHARACTER) is
-- 2.6 map S(I) into escaped character, increment I
-- this procedure is substituted for the equivalent SOFTWARE TOOLS function
-- since Ada will not abide side effect of an in out parameter in function
-- further it prepares for a wide range of escaped characters
--ESCAPED : array(CHARACTER range 'A'..'z') of CHARACTER :=
--('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
--NEWLINE, 'O', 'P', 'Q', 'R', 'S', TAB, 'U', 'V', 'W', 'X', 'Y', 'Z',
--'[', '\', ']', '^', '_', '|',
--'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
--NEWLINE, 'o', 'p', 'q', 'r', 's', TAB, 'u', 'v', 'w', 'x', 'y', 'z');
-- Put in to simulate the character array that is not yet implemented
function ESCAPED(C : in CHARACTER) return CHARACTER is
Q : CHARACTER;
begin
Q := C;
if (C = 'N') or (C = 'n') then
return NEWLINE;
elsif (C = 'T') or (C = 't') then
return TAB;
else
return Q;
end if;
end ESCAPED;
begin
if S(I) /= ESCAPE then
ESCAPED_CHAR := S(I);
elsif S(I+1) = ENDSTR then -- ESCAPE not special at end
ESCAPED_CHAR := ESCAPE;
else
I := I + 1;
ESCAPED_CHAR := ESCAPED(S(I));
end if;
end CONVERT_ESCAPED;
function ISALPHANUM(C : CHARACTER) return BOOLEAN is
-- 2.6 if C is letter or digit
begin
return (C in 'A'..'Z') or (C in 'a'..'z') or (C in '0'..'9');
end ISALPHANUM;
procedure ADDSTR(C : in CHARACTER;
OUTSET : in out STRING;
J : in out INTEGER;
MAX_OF : in INTEGER) is
-- 2.6 put C in OUTSET(J) if it fits, increment J
-- substituted a procedure for the SOFTWARE TOOLS function
begin
if J > MAX_OF then
--ADDSTR_OK := FALSE; --####################################
return;
else
OUTSET(J) := C;
J := J + 1;
--ADDSTR_OK := TRUE; --#####################################
end if;
end ADDSTR;
procedure DODASH(DELIM : in CHARACTER;
SRC : in STRING;
I : in out INTEGER;
DEST : in out STRING;
J : in out INTEGER;
MAX_OF : in INTEGER) is
-- 2.6 expand set at SRC(I) into DEST(J), stop at DELIM
K : CHARACTER;
begin
while (SRC(I) /= DELIM) and (SRC(I) /= ENDSTR) loop
if SRC(I) = ESCAPE then
CONVERT_ESCAPED(SRC, I, ESCAPED_CHAR);
ADDSTR(ESCAPED_CHAR, DEST, J, MAXSET);
elsif SRC(I) /= DASH then
ADDSTR(SRC(I), DEST, J, MAXSET);
elsif J <= 1 or SRC(I+1) = ENDSTR then
ADDSTR(DASH, DEST, J, MAXSET); -- literal -
elsif ISALPHANUM(SRC(I-1)) and ISALPHANUM(SRC(I+1)) and
SRC(I-1) <= SRC(I+1) then
for K in CHARACTER'VAL(CHARACTER'POS(SRC(I-1)) + 1)..SRC(I+1) loop
ADDSTR(K, DEST, J, MAXSET);
end loop;
I := I + 1;
else
ADDSTR(DASH, DEST, J, MAXSET);
end if;
I := I + 1;
end loop;
end DODASH;
procedure MAKESET(INSET : in STRING;
K : in out INTEGER;
OUTSET : in out STRING;
MAX_OF : in INTEGER) is
-- 2.6 make set from INSET(K) in OUTSET
-- procedure rather than function
J : INTEGER := 1;
begin
DODASH(ENDSTR, INSET, K, OUTSET, J, MAXSET);
ADDSTR(ENDSTR, OUTSET, J, MAXSET);
exception
when ADDSTR_ERROR =>
raise MAKESET_ERROR;
end MAKESET;
function INDEX(S : STRING; C : CHARACTER) return INTEGER is
-- 2.6 find position of character C in string S
I : INTEGER := 1;
begin
while S(I) /= C and S(I) /= ENDSTR loop
I := I + 1;
end loop;
if S(I) = ENDSTR then
return 0;
else
return I;
end if;
end INDEX;
function XINDEX(INSET : STRING; C : CHARACTER;
ALLBUT : BOOLEAN; LASTTO : INTEGER) return INTEGER is
-- 2.6 conditionally invert value from index
begin
if C = ENDFILE then
return 0;
elsif not ALLBUT then
return INDEX(INSET, C);
elsif INDEX(INSET, C) > 0 then
return 0;
else
return LASTTO + 1;
end if;
end XINDEX;
procedure TRANSLIT is
-- 2.6 map characters
ARGSTR, FROMSET, TOSET : STRING(1..MAXSTR);
C : CHARACTER;
I, K, LASTTO : INTEGER;
ALLBUT, SQUASH : BOOLEAN;
begin
GETARG_FROMSET:
begin
GETARG(1, ARGSTR, MAXSTR);
exception
when GETARG_ERROR =>
ERROR("usage: translit from to");
raise TRANSLIT_ERROR;
end GETARG_FROMSET;
ALLBUT := (ARGSTR(1) = NEGATE);
if ALLBUT then
I := 2;
else
I := 1;
end if;
MAKE_FROMSET:
begin
MAKESET(ARGSTR, I, FROMSET, MAXSTR);
exception
when MAKESET_ERROR =>
ERROR("translit: from set too large");
raise TRANSLIT_ERROR;
end MAKE_FROMSET;
GETARG_TOSET:
begin
GETARG(2, ARGSTR, MAXSTR);
K := 1; -- Dummy to MAKESET 1
MAKE_TOSET:
begin
MAKESET(ARGSTR, K, TOSET, MAXSTR);
exception
when MAKESET_ERROR =>
ERROR("translit: to set too large");
raise TRANSLIT_ERROR;
end MAKE_TOSET;
if LENGTH(FROMSET) < LENGTH(TOSET) then
ERROR("translit: from shorter than to");
raise TRANSLIT_ERROR;
end if;
exception
when GETARG_ERROR =>
TOSET(1) := ENDSTR;
end GETARG_TOSET;
LASTTO := LENGTH(TOSET);
SQUASH := (LENGTH(FROMSET) > LASTTO) or ALLBUT;
loop
GETC(C);
I := XINDEX(FROMSET, C, ALLBUT, LASTTO);
if SQUASH and (I >= LASTTO) and (LASTTO > 0) then
PUT(TOSET(LASTTO));
loop
GETC(C);
I := XINDEX(FROMSET, C, ALLBUT, LASTTO);
exit when I < LASTTO;
end loop;
end if;
if C /= ENDFILE then
if (I > 0) and (LASTTO > 0) then -- translate
PUT(TOSET(I));
elsif I = 0 then -- copy
PUT(C);
end if;
end if;
exit when C = ENDFILE;
end loop;
exception
when TRANSLIT_ERROR =>
PUT("TRANSLIT ERROR");
return;
when END_ERROR =>
return;
end TRANSLIT;
begin
null;
end CHAPTER_2;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--cli2.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO; use TEXT_IO;
with CHAPTER_1; use CHAPTER_1;
with CHAPTER_2; use CHAPTER_2;
procedure CLI_2 is
type COMMAND_TYPE is (COPY, CHARCOUNT, LINECOUNT, WORDCOUNT, DETAB,
ENTAB, OVERSTRIKE, COMPRESS, EXPAND, TRANSLIT,
QUIT, QUERY, UNKNOWN, REFUSED, ABORTING);
COMMAND : COMMAND_TYPE;
COMMAND_LINE : STRING(1..MAXLINE);
UNKNOWN_COUNT : INTEGER := 0;
TRYING_AGAIN : BOOLEAN := FALSE;
function CONVERT_TO_UPPER_CASE(C : CHARACTER) return CHARACTER is
--UPPER_CASE : array(CHARACTER range 'a'..'z') of CHARACTER
--:= ('A','B','C','D','E','F','G','H','I','J','K','L','M',
--'N','O','P','Q','R','S','T','U','V','W','X','Y','Z');
function UPPER_CASE(C : CHARACTER) return CHARACTER is
begin
if C in 'a'..'z' then
return CHARACTER'VAL(CHARACTER'POS(C) - 32);
else
return C;
end if;
end UPPER_CASE;
begin
if C in 'a'..'z' then
return UPPER_CASE(C);
else
return C;
end if;
end CONVERT_TO_UPPER_CASE;
function CONVERT_TO_UPPER_CASE(S : STRING) return STRING is
T : STRING(S'FIRST..S'LAST);
begin
for I in S'RANGE loop
T(I) := CONVERT_TO_UPPER_CASE(S(I));
end loop;
return T;
end CONVERT_TO_UPPER_CASE;
procedure PUT_OUT(LINE : in STRING) is
-- Always have the PUT before the GET if possible so you can use it
-- in diagnostics in developing the GET if necessary
begin
for I in 1..MAXLINE loop
if LINE(I) = ENDLINE then
NEW_LINE;
exit;
else
PUT(LINE(I));
end if;
end loop;
end PUT_OUT;
procedure GET_COMMAND_LINE(COMMAND_LINE : out STRING) is
C : CHARACTER := ' ';
LINE_LENGTH : INTEGER := MAXLINE;
begin
GET_LINE(COMMAND_LINE, LINE_LENGTH);
COMMAND_LINE(LINE_LENGTH + 1) := ENDLINE;
exception
when others =>
null;
end GET_COMMAND_LINE;
function IS_ARGUMENT_SEPARATOR(C : CHARACTER) return BOOLEAN is
begin
return C = BLANK
or C = TAB
or C = LF
or C = '('
or C = ','
or C = '/';
end IS_ARGUMENT_SEPARATOR;
function IS_ARGUMENT_TERMINATOR(C : CHARACTER) return BOOLEAN is
begin
return C = ENDSTR
or C = NEWLINE
or C = ')'
or C = ';';
end IS_ARGUMENT_TERMINATOR;
procedure GET_ARGUMENTS(S : in STRING; I : in INTEGER) is
N : INTEGER := 0;
J : INTEGER := 1;
K : INTEGER := 1;
QUOTE : BOOLEAN := FALSE;
begin
J := I;
while ( not IS_ARGUMENT_SEPARATOR(S(J)) )
and ( not IS_ARGUMENT_TERMINATOR(S(J)) ) loop
J := J + 1; -- eat rest of the command
end loop;
while not IS_ARGUMENT_TERMINATOR(S(J)) loop
N := N + 1;
while S(J) = BLANK or S(J) = TAB loop
J := J + 1; -- eat blanks
end loop;
K := 1;
while ( ( not IS_ARGUMENT_SEPARATOR(S(J)) )
and ( not IS_ARGUMENT_TERMINATOR(S(J)) ) )
or QUOTE loop
if not QUOTE and S(J) = '"' then
QUOTE := TRUE;
elsif QUOTE and S(J) = '"' then
QUOTE := FALSE;
else
ARGUMENTS(N)(K) := S(J);
K := K + 1;
end if;
J := J + 1;
end loop;
ARGUMENTS(N)(K) := ENDSTR;
end loop;
NUMBER_OF_ARGUMENTS := N;
return;
end GET_ARGUMENTS;
procedure PUT_ARGUMENTS is
begin
for N in 1..NUMBER_OF_ARGUMENTS loop
for K in 1..MAXSTR loop
exit when ARGUMENTS(N)(K) = ENDSTR;
PUT(ARGUMENTS(N)(K));
end loop;
exit when N = NUMBER_OF_ARGUMENTS; -- So you dont finish on a comma
PUT(""", """); -- Only string arguments so far
end loop;
return;
end PUT_ARGUMENTS;
procedure PARSE_2(COMMAND_LINE : in STRING;
COMMAND : out COMMAND_TYPE) is
CONFIRMATION : STRING(1..MAXLINE);
CONFIRMATION_LENGTH : NATURAL := 0;
I : INTEGER;
procedure LIST_COMMANDS is
begin
PUT("COMMANDS ARE -- COPY, CHARCOUNT, LINECOUNT, WORDCOUNT, DETAB,");
NEW_LINE;
PUT(" ENTAB, OVERSTRIKE, COMPRESS, EXPAND, TRANSLIT,");
NEW_LINE;
PUT(" QUIT"); NEW_LINE;
end LIST_COMMANDS;
begin
NEW_LINE;
I := 0;
loop
I := I + 1;
if I = MAXLINE then
COMMAND := UNKNOWN;
UNKNOWN_COUNT := UNKNOWN_COUNT + 1;
return;
end if;
if COMMAND_LINE(I) /= BLANK then -- Eat blanks
if CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+2)) = "COP" then
COMMAND := COPY;
PUT("COPY; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "CH" then
COMMAND := CHARCOUNT;
PUT("CHARCOUNT; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "LI" then
COMMAND := LINECOUNT;
PUT("LINECOUNT; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "WO" then
COMMAND := WORDCOUNT;
PUT("WORDCOUNT; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "DE" then
COMMAND := DETAB;
PUT("DETAB; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "DE" then
COMMAND := DETAB;
PUT("DETAB; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "EN" then
COMMAND := ENTAB;
PUT("ENTAB; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "OV" then
COMMAND := OVERSTRIKE;
PUT("OVERSTRIKE; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+2)) = "COM" then
COMMAND := COMPRESS;
PUT("COMPRESS; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+2)) = "EXP" then
COMMAND := EXPAND;
PUT("EXPAND; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+1)) = "TR" then
COMMAND := TRANSLIT;
GET_ARGUMENTS(COMMAND_LINE, I+2);
PUT("TRANSLIT("""); -- Only string arguments so far
PUT_ARGUMENTS;
PUT("""); [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I )) = "Q" then
COMMAND := QUIT;
PUT("QUIT; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I+2)) = "EXI" then
COMMAND := QUIT;
PUT("QUIT; [Confirm with CR] -->");
elsif CONVERT_TO_UPPER_CASE(COMMAND_LINE(I..I )) = "?" then
COMMAND := QUERY;
LIST_COMMANDS;
return;
else
COMMAND := UNKNOWN;
PUT("COMMAND NOT RECOGNIZED ");
NEW_LINE;
UNKNOWN_COUNT := UNKNOWN_COUNT + 1;
if UNKNOWN_COUNT < 3 then
PUT("TRY AGAIN "); NEW_LINE;
return;
end if;
end if;
exit;
end if;
end loop;
if UNKNOWN_COUNT >= 3 then
if TRYING_AGAIN = FALSE then
PUT("YOU ARE NOT MAKING IT"); NEW_LINE;
LIST_COMMANDS;
COMMAND := UNKNOWN;
UNKNOWN_COUNT := 0;
TRYING_AGAIN := TRUE;
return;
else
PUT("THREE FAILURES IN A ROW -- AGAIN -- ABORTING CLI_1 ");
COMMAND := ABORTING;
return;
end if;
end if;
GET_LINE(CONFIRMATION, CONFIRMATION_LENGTH);
if CONFIRMATION_LENGTH /= 0 then -- Just a CR gives no LENGTH
COMMAND := REFUSED;
UNKNOWN_COUNT := UNKNOWN_COUNT + 1;
PUT("?"); NEW_LINE;
else
PUT("CONFIRMED!"); NEW_LINE;
UNKNOWN_COUNT := 0;
TRYING_AGAIN := FALSE;
end if;
return;
end PARSE_2;
begin
loop
NEW_LINE;
PUT("CLI_2 -->");
GET_COMMAND_LINE(COMMAND_LINE);
PARSE_2(COMMAND_LINE, COMMAND);
case COMMAND is
when COPY => CHAPTER_1.COPY;
when CHARCOUNT => CHAPTER_1.CHARCOUNT;
when LINECOUNT => CHAPTER_1.LINECOUNT;
when WORDCOUNT => CHAPTER_1.WORDCOUNT;
when DETAB => CHAPTER_1.DETAB;
when ENTAB => CHAPTER_2.ENTAB;
when OVERSTRIKE => CHAPTER_2.OVERSTRIKE;
when COMPRESS => CHAPTER_2.COMPRESS;
when EXPAND => CHAPTER_2.EXPAND;
when TRANSLIT => CHAPTER_2.TRANSLIT;
when QUIT => exit;
when QUERY => null;
when UNKNOWN => null;
when REFUSED => null;
when ABORTING => exit;
end case;
end loop;
PUT("QUIT CLI_2");
NEW_LINE;
end CLI_2;