v04i026: Turbo Pascal to C -- TEST CASES, part 1/2
Alan Strassberg
alan at leadsv.UUCP
Mon Aug 15 08:58:33 AEST 1988
Posting-number: Volume 4, Issue 26
Submitted-by: "Alan Strassberg" <alan at leadsv.UUCP>
Archive-name: tptctest/Part1
[WARNING!!! This software is shareware and copyrighted. Those who do not
accept such programs should give this a miss. ++bsa]
#--------------------------------CUT HERE-------------------------------------
#! /bin/sh
#
# This is a shell archive. Save this into a file, edit it
# and delete all lines above this comment. Then give this
# file to sh by executing the command "sh file". The files
# will be extracted into the current directory owned by
# you with default permissions.
#
# The files contained herein are:
#
# -rw-r--r-- 1 allbery System 343 Aug 14 17:08 acker.pas
# -rw-r--r-- 1 allbery System 48 Aug 14 17:08 compall.bat
# -rw-r--r-- 1 allbery System 32 Aug 14 17:08 compold.bat
# -rw-r--r-- 1 allbery System 4499 Aug 14 17:08 dia.pas
# -rw-r--r-- 1 allbery System 1403 Aug 14 17:08 dial.pas
# -rw-r--r-- 1 allbery System 277 Aug 14 17:08 doall.bat
# -rw-r--r-- 1 allbery System 1091 Aug 14 17:08 findchrs.pas
# -rw-r--r-- 1 allbery System 5132 Aug 14 17:08 fmap.pas
# -rw-r--r-- 1 allbery System 1785 Aug 14 17:08 linklist.pas
# -rw-r--r-- 1 allbery System 32 Aug 14 17:08 look.bat
# -rw-r--r-- 1 allbery System 6778 Aug 14 17:08 minicrt.pas
# -rw-r--r-- 1 allbery System 1300 Aug 14 17:08 mtplus.pas
# -rw-r--r-- 1 allbery System 531 Aug 14 17:08 point4.pas
# -rw-r--r-- 1 allbery System 451 Aug 14 17:08 pointers.pas
# -rw-r--r-- 1 allbery System 4577 Aug 14 17:08 puzzle.pas
# -rw-r--r-- 1 allbery System 2131 Aug 14 17:08 qsort.pas
# -rw-r--r-- 1 allbery System 3939 Aug 14 17:08 readme
# -rw-r--r-- 1 allbery System 2060 Aug 14 17:08 sets.pas
#
echo 'x - acker.pas'
if test -f acker.pas; then echo 'shar: not overwriting acker.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > acker.pas
X
X(*
X * Ackerman function
X *)
X
Xprogram Acker;
X
XVar
X R : Integer;
X
X function A(M, N : Integer) : Integer;
X begin
X if M = 0 then
X A := N+1
X else
X if N = 0 then
X A := A(M-1, 1)
X else
X A := A(M-1, A(M, N-1));
X end;
X
Xbegin
X WriteLn('Ackerman function...');
X R := A(3, 6);
X WriteLn('finished, R=',R);
Xend.
________This_Is_The_END________
if test `wc -c < acker.pas` -ne 343; then
echo 'shar: acker.pas was damaged during transit (should have been 343 bytes)'
fi
fi ; : end of overwriting check
echo 'x - compall.bat'
if test -f compall.bat; then echo 'shar: not overwriting compall.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > compall.bat
Xfor %%f in (*.c) do call compold %%f
Xq \tmp\*.c
________This_Is_The_END________
if test `wc -c < compall.bat` -ne 48; then
echo 'shar: compall.bat was damaged during transit (should have been 48 bytes)'
fi
fi ; : end of overwriting check
echo 'x - compold.bat'
if test -f compold.bat; then echo 'shar: not overwriting compold.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > compold.bat
X at echo off
Xfc %1 old\%1 >\tmp\%1
________This_Is_The_END________
if test `wc -c < compold.bat` -ne 32; then
echo 'shar: compold.bat was damaged during transit (should have been 32 bytes)'
fi
fi ; : end of overwriting check
echo 'x - dia.pas'
if test -f dia.pas; then echo 'shar: not overwriting dia.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > dia.pas
X
X(*
X * hardware diagnostic utility
X * s.h.smith, 13-jan-87
X *
X *)
X{$c-}
X
Xtype
X anystring = string[80];
Xvar
X hardware: char;
X
Xfunction digit(i: integer): char;
Xbegin
X i := i and 15;
X if i > 9 then i := i + 7;
X digit := chr(i + ord('0'));
Xend;
X
Xfunction itoh(i: integer): anystring;
Xbegin
X itoh := {digit(i shr 12) + digit(i shr 8) + }
X digit(i shr 4) + digit(i);
Xend;
X
Xfunction itob(i: integer): anystring;
Xconst
X bits: array[0..15] of anystring =
X ('0000','0001','0010','0011',
X '0100','0101','0110','0111',
X '1000','1001','1010','1011',
X '1100','1101','1110','1111');
Xbegin
X itob := bits[(i shr 4) and 15] + bits[i and 15];
Xend;
X
Xfunction htoi(h:anystring): integer;
Xvar
X i,j: integer;
Xbegin
X j := 0;
X for i := 1 to length(h) do
X j := j * 16 + pos(upcase(h[i]),'123456789ABCDEF');
X htoi := j;
Xend;
X
Xprocedure determine_hardware;
Xbegin
X port[$342] := 6;
X case port[$342] and 7 of
X 1: hardware := 'B';
X 7,0: hardware := 'A';
X else hardware := 'B';
X end;
X
X writeln('hardware: rev ',hardware);
Xend;
X
X
Xprocedure readanalog;
Xvar
X h,l: integer;
X s: anystring;
X d: char;
X
Xbegin
X write('display data (y/n/b)? ');
X read(kbd,s[1]);
X d := upcase(s[1]);
X
X while not keypressed do
X begin
X port[$341] := 0; {start conversion};
X repeat
X l := port[$342];
X until ((l and $80) = 0) or keypressed;
X
X l := port[$340];
X h := port[$341];
X
X case d of
X 'Y': write(itoh(h),itoh(l),' ');
X 'B': write(itob(h),itob(l),' ');
X end;
X end;
Xend;
X
X
Xprocedure readport;
Xvar
X p: integer;
X s: anystring;
X d: integer;
X
Xbegin
X write('read what port(hex): ');
X readln(s);
X p := htoi(s);
X
X write('display data(y/n/b)? ');
X read(kbd,s[1]);
X
X writeln('reading from port $',itoh(hi(p)), itoh(lo(p)));
X
X if upcase(s[1]) = 'Y' then
X while not keypressed do
X write(itoh(port[p]),' ')
X else
X
X if upcase(s[1]) = 'B' then
X while not keypressed do
X write(itob(port[p]),' ')
X
X else
X while not keypressed do
X d := port[p];
Xend;
X
X
Xprocedure writetest;
Xvar
X p: integer;
X d: integer;
X d2:integer;
X s: anystring;
X
Xbegin
X write('write what port(hex): ');
X readln(s);
X p := htoi(s);
X
X write('write what data(hex): ');
X readln(s);
X d := htoi(s);
X
X writeln('writing data $',itoh(lo(d)),
X ' to port $',itoh(hi(p)), itoh(lo(p)));
X
X while not keypressed do
X port[p] := d;
Xend;
X
X
X
Xprocedure writetoggle;
Xvar
X p: integer;
X d: integer;
X d1: integer;
X s: anystring;
X v: integer;
X
Xbegin
X write('write toggle to what port(hex): ');
X readln(s);
X p := htoi(s);
X
X write('toggle from bits(hex): ');
X read(s);
X d := htoi(s);
X
X write(' to bits(hex): ');
X readln(s);
X d1 := htoi(s);
X
X writeln('toggle data between $',itoh(d),' and $',itoh(d1),
X ' to port $',itoh(hi(p)), itoh(lo(p)));
X
X while not keypressed do
X for v := 1 to 5 do
X begin
X port[p] := d;
X port[p] := d1;
X end;
Xend;
X
X
Xprocedure setmux;
Xvar
X m: integer;
Xbegin
X write('what mux channel 0..7: ');
X readln(m);
X port[$342] := m;
Xend;
X
X
Xprocedure pause;
Xbegin
X writeln;
X write('press <enter> to continue');
X readln;
X writeln;
Xend;
X
Xprocedure map_ports;
Xbegin
X writeln('DASH8_base_address = $340;');
X writeln('DASH8_data_lo = $340; {low data register}');
X writeln('DASH8_data_hi = $341; {high data register}');
X writeln('DASH8_start_cmd = $341; {start-conversion by writing to this port}');
X writeln('DASH8_op_port = $342; {parallel output}');
X writeln(' ANALOG_mux_bits = $07; {multiplex select bits}');
X writeln(' old_ANALOG_power_supply_enable_bit = $80;');
X writeln('DASH8_ip_port = $342; {parallel input}');
X writeln(' hardware_version_mask = $7;');
X writeln(' ANALOG_end_conversion = $80; {low when conversion is finished}');
X pause;
Xend;
X
Xvar
X cmd: anystring;
X
Xbegin
X textbackground(0);
X clrscr;
X
X repeat
X writeln;
X writeln('hardware diagnostic 14-jan-87 (30-apr-87)');
X determine_hardware;
X
X writeln;
X write('read, write, toggle, analog, mux, ?=map (r/w/t/a/m/?/q)? ');
X read(kbd,cmd[1]);
X writeln(cmd[1]);
X
X case upcase(cmd[1]) of
X 'R': readport;
X 'W': writetest;
X 'T': writetoggle;
X 'A': readanalog;
X 'M': setmux;
X 'Q': halt;
X '?': map_ports;
X end;
X
X if keypressed then
X read(kbd,cmd[1]);
X
X until true=false;
Xend.
X
________This_Is_The_END________
if test `wc -c < dia.pas` -ne 4499; then
echo 'shar: dia.pas was damaged during transit (should have been 4499 bytes)'
fi
fi ; : end of overwriting check
echo 'x - dial.pas'
if test -f dial.pas; then echo 'shar: not overwriting dial.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > dial.pas
X
X(*
X * Usage: DIAL xxx-xxxx
X *)
X
Xprogram Dial;
X {dials number on command line to Hayes compatible modem on COM1}
X
Xconst
X Com_Base = $3F8; {Use 3F8 for COM1, 2F8 for COM2}
X
X {Offsets from Com_Base for async control ports }
X RX = 0; {Receiver Buffer Register }
X TX = 0; {Transmitter Buffer Register }
X LC = 3; {Line Control Register }
X MC = 4; {Modem Control Register }
X LS = 5; {Line Status Register }
X DLL = 0; {Divisor Latch, Low Order Byte }
X DLH = 1; {Divisor Latch, High Order Byte}
X
X No_Parity = $03;
X
Xtype
X anystring = string[80];
X
X
Xprocedure send(command: anystring);
Xvar
X P: integer;
X C: char;
X I: integer;
X
Xbegin
X
X {send string to modem}
X for P := 1 to length(command) do
X begin
X C := command[P];
X Port[com_base+TX] := C;
X repeat
X until Port[com_base+LS] >= $20;
X P := Succ(P);
X
X I := 0;
X repeat
X I := Succ(I);
X until I >= 1000;
X end;
Xend;
X
X
Xbegin
X {init modem}
X Port[com_base+LC] := $83; {Set baud rate, No parity, 8 bits}
X Port[com_base+DLL] := 96; {1200 baud}
X Port[com_base+DLH] := 0;
X Port[com_base+LC] := No_Parity;
X Port[com_base+MC] := $03; {Turn ON DTR and RTS}
X
X {set up modem control string}
X send('ATDT' + paramstr(1) + ^M);
Xend.
________This_Is_The_END________
if test `wc -c < dial.pas` -ne 1403; then
echo 'shar: dial.pas was damaged during transit (should have been 1403 bytes)'
fi
fi ; : end of overwriting check
echo 'x - doall.bat'
if test -f doall.bat; then echo 'shar: not overwriting doall.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > doall.bat
Xrem translate all sample programs to c
Xset tptc=-l -wj: -sc:\inc -i
Xfor %%f in (tptcsys minicrt acker dia dial fmap puzzle qsort sieve test test2 unsq) do tptc %%f
Xfor %%f in (varrec timedat4 smallrec subrange sets pointers point4 linklist findchrs) do tptc %%f
Xtptc mtplus -m
________This_Is_The_END________
if test `wc -c < doall.bat` -ne 277; then
echo 'shar: doall.bat was damaged during transit (should have been 277 bytes)'
fi
fi ; : end of overwriting check
echo 'x - findchrs.pas'
if test -f findchrs.pas; then echo 'shar: not overwriting findchrs.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > findchrs.pas
X
X(*
X * Example of sets of characters
X *
X *)
X
Xprogram Find_All_Lower_Case_Characters;
X
Xconst
X String_Size = 30;
X
Xtype
X Low_Set = set of 'a'..'z';
X
Xvar
X Data_Set : Low_Set;
X Storage : string[String_Size];
X Index : 1..String_Size;
X Print_Group : string[26];
X
Xbegin (* main program *)
X Data_Set := [];
X Print_Group := '';
X Storage := 'This is a set test.';
X
X for Index := 1 to Length(Storage) do begin
X if Storage[Index] in ['a'..'z'] then begin
X if Storage[Index] in Data_Set then
X Writeln(Index:4,' ',Storage[Index],
X ' is already in the set')
X else begin
X Data_Set := Data_Set + [Storage[Index]];
X Print_Group := Print_Group + Storage[Index];
X Writeln(Index:4,' ',Storage[Index],
X ' added to group, complete group = ',
X Print_Group);
X end;
X end
X else
X Writeln(Index:4,' ',Storage[Index],
X ' is not a lower case letter');
X end;
Xend. (* of main program *)
________This_Is_The_END________
if test `wc -c < findchrs.pas` -ne 1091; then
echo 'shar: findchrs.pas was damaged during transit (should have been 1091 bytes)'
fi
fi ; : end of overwriting check
echo 'x - fmap.pas'
if test -f fmap.pas; then echo 'shar: not overwriting fmap.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > fmap.pas
X
X(*
X * fmap - find symbols related to an address in a .MAP load
X * map generated by LINK or TMAP
X *
X * S.H.Smith, 27-jan-86
X *
X *)
X
X{$g512,p512,c-}
X
Xconst
X version = 'FMAP 1.0 (1/26/87 SHS)';
X
Xtype
X anystring = string[80];
X
Xvar
X line: anystring;
X fd: text[10240];
X target: anystring;
X mapname: anystring;
X
X
Xprocedure abort_check;
Xbegin
X if keypressed then
X begin
X writeln('aborted');
X halt;
X end;
Xend;
X
X
Xprocedure parse_segments;
Xbegin
X writeln('Segments');
X repeat
X readln(fd,line);
X until length(line) < 20;
Xend;
X
X
Xprocedure parse_by_name;
Xbegin
X writeln('Names');
X readln(fd,line);
X
X repeat
X readln(fd,line);
X abort_check;
X until length(line) < 17;
Xend;
X
X
Xprocedure parse_by_value;
Xvar
X pr: anystring;
X ad: anystring;
X ppr: anystring;
X pad: anystring;
X pline: anystring;
X
Xbegin
X writeln('Values');
X readln(fd,line);
X pad := '0000';
X ppr := '';
X
X repeat
X ad := copy(line,7,4);
X pr := copy(line,18,99);
X if (ppr <> '') and (target >= pad) and (target < ad) then
X writeln(pad,'-',ad,' ',pline);
X
X pad := ad;
X ppr := pr;
X pline := line;
X
X readln(fd,line);
X abort_check;
X until length(line) < 17;
Xend;
X
X
Xprocedure output_lines(name: anystring; first, last: integer);
Xvar
X fd: text[1024];
X n: integer;
X b: anystring;
X
Xbegin
X writeln('Output lines ',first,'-',last,' from ',name);
X assign(fd,name);
X{$i-}
X reset(fd);
X{$i+}
X if ioresult <> 0 then
X begin
X writeln('can''t find source file: ',name);
X writeln('need lines ',first,'-',last);
X halt;
X end;
X
X{$i-}
X for n := 1 to first-1 do
X readln(fd,b);
X
X for n := first to last+1 do
X begin
X writeln(n:6,'| ',b);
X readln(fd,b);
X abort_check;
X end;
X{$i+}
X
X close(fd);
Xend;
X
X
Xvar
X name: anystring;
X ln: integer;
X ad: anystring;
X pln: integer;
X pad: anystring;
X first: boolean;
X
X procedure check_match;
X begin
X writeln(' check match, ',pad,'-',ad,' lines ',pln,'-',ln);
X
X if (pln <> 0) and (target >= pad) and (target < ad) then
X begin
X if first then
X begin
X writeln;
X writeln('==============================');
X writeln(name);
X first := false;
X end;
X
X if (ln-pln) < 20 then
X begin
X writeln('---------');
X writeln(pad,'-',ad);
X output_lines(name,pln,ln);
X end
X else
X begin
X writeln('---------');
X writeln(pad,'-',ad,' lines ',pln,'-',ln);
X end;
X end;
X end;
X
Xprocedure parse_line_numbers;
Xvar
X i: integer;
X code: integer;
X buf: anystring;
X
Xbegin
X writeln('Line numbers: ',line);
X
X i := pos('(',line) + 1;
X name := '';
X while line[i] <> ')' do
X begin
X name := name + line[i];
X i := i + 1;
X end;
X
X readln(fd,line);
X writeln('name=[',name,']');
X
X pln := 0;
X pad := '0000';
X first := true;
X
X repeat
X abort_check;
X
X while length(line) > 6 do
X begin
X
X {extract the line number}
X buf := copy(line,1,5);
X while copy(buf,1,1) = ' ' do
X delete(buf,1,1);
X val(buf,ln,code);
X
X {extract the code address}
X ad := copy(line,12,4);
X
X {remove the processed part of the line}
X delete(line,1,17);
X
X {if target is between two lines, then print it out}
X check_match;
X
X pad := ad;
X pln := ln;
X end;
X
X readln(fd,line);
X until length(line) < 6;
X
X check_match; {process the last line}
Xend;
X
X
Xprocedure parse_others;
Xbegin
X writeln('Other: ',line);
X readln(fd,line);
Xend;
X
X
Xprocedure parse_mapfile;
Xbegin
X writeln('Scanning mapfile ',mapname);
X writeln('for address ',target,':');
X writeln;
X
X readln(fd,line);
X
X while not eof(fd) do
X begin
X if copy(line,1,30) = ' Start Stop Length Name ' then
X parse_segments
X else
X if copy(line,1,30) = ' Address Publics by N' then
X parse_by_name
X else
X if copy(line,1,30) = ' Address Publics by V' then
X parse_by_value
X else
X if copy(line,1,17) = 'Line numbers for ' then
X parse_line_numbers
X else
X parse_others;
X
X abort_check;
X end;
X
X close(fd);
Xend;
X
X
Xvar
X i: integer;
X
Xbegin
X writeln;
X writeln(version);
X writeln;
X
X if paramcount <> 2 then
X begin
X writeln('Usage: fmap MAPFILE TARGET_ADDRESS');
X writeln('Finds references to TARGET_ADDRESS in MAPFILE.');
X halt(1);
X end;
X
X mapname := paramstr(1);
X if pos('.',mapname) = 0 then
X mapname := mapname + '.MAP';
X
X assign(fd,mapname);
X{$i-}
X reset(fd);
X{$i+}
X if ioresult <> 0 then
X begin
X writeln('can''t open mapfile: ',mapname);
X halt;
X end;
X
X target := paramstr(2);
X for i := 1 to length(target) do
X target[i] := upcase(target[i]);
X
X if length(target) <> 4 then
X begin
X writeln('TARGET_ADDRESS must be 4 hex digits');
X halt;
X end;
X
X parse_mapfile;
X writeln;
Xend.
X
________This_Is_The_END________
if test `wc -c < fmap.pas` -ne 5132; then
echo 'shar: fmap.pas was damaged during transit (should have been 5132 bytes)'
fi
fi ; : end of overwriting check
echo 'x - linklist.pas'
if test -f linklist.pas; then echo 'shar: not overwriting linklist.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > linklist.pas
X
X(*
X * Example of pointer manipulation with circular type declarations
X *
X *)
X
Xprogram Linked_List_Example;
X
Xtype
X Next_Pointer = ^Full_Name;
X
X Full_Name = record
X First_Name : string[12];
X Initial : char;
X Last_Name : string[15];
X Next : Next_Pointer;
X end;
X
Xvar
X Start_Of_List : Next_Pointer;
X Place_In_List : Next_Pointer;
X Temp_Place : Next_Pointer;
X Index : integer;
X
Xbegin (* main program *)
X (* generate the first name in the list *)
X New(Place_In_List);
X Start_Of_List := Place_In_List;
X Place_In_List^.First_Name := 'John';
X Place_In_List^.Initial := 'Q';
X Place_In_List^.Last_Name := 'Doe';
X Place_In_List^.Next := nil;
X (* generate another name in the list *)
X Temp_Place := Place_In_List;
X New(Place_In_List);
X Temp_Place^.Next := Place_In_List;
X Place_In_List^.First_Name := 'Mary';
X Place_In_List^.Initial := 'R';
X Place_In_List^.Last_Name := 'Johnson';
X Place_In_List^.Next := nil;
X (* add 10 more names to complete the list *)
X for Index := 1 to 10 do begin
X Temp_Place := Place_In_List;
X New(Place_In_List);
X Temp_Place^.Next := Place_In_List;
X Place_In_List^.First_Name := 'William';
X Place_In_List^.Initial := 'S';
X Place_In_List^.Last_Name := 'Jones';
X Place_In_List^.Next := nil;
X end;
X (* display the list on the video monitor *)
X Place_In_List := Start_Of_List;
X repeat
X Write(Place_In_List^.First_Name);
X Write(' ',Place_In_List^.Initial);
X Writeln(' ',Place_In_List^.Last_Name);
X Temp_Place := Place_In_List;
X Place_In_List := Place_In_List^.Next;
X until Temp_Place^.Next = nil;
Xend. (* of main program *)
________This_Is_The_END________
if test `wc -c < linklist.pas` -ne 1785; then
echo 'shar: linklist.pas was damaged during transit (should have been 1785 bytes)'
fi
fi ; : end of overwriting check
echo 'x - look.bat'
if test -f look.bat; then echo 'shar: not overwriting look.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > look.bat
Xfind "%1" *.inc tptc.pas >t
Xq t
________This_Is_The_END________
if test `wc -c < look.bat` -ne 32; then
echo 'shar: look.bat was damaged during transit (should have been 32 bytes)'
fi
fi ; : end of overwriting check
echo 'x - minicrt.pas'
if test -f minicrt.pas; then echo 'shar: not overwriting minicrt.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > minicrt.pas
X
X(*
X * MiniCrt - simplified version of Borland's CRT unit.
X * Does not EVER do direct video. The standard crt unit
X * locks up multi-taskers with its direct video checking before
X * the user program can turn it off.
X *
X * Samuel H. Smith, 20-dec-87
X *
X *)
X
X{$i prodef.inc}
X
Xunit MiniCrt;
X
Xinterface
X
X uses
X Dos;
X
X var
X stdout: text; {output through dos for ANSI compatibility}
X
X function KeyPressed: Boolean;
X function ReadKey: Char;
X
X procedure Window(X1,Y1,X2,Y2: Byte); {only partial support}
X
X procedure GotoXY(X,Y: Byte);
X function WhereX: Byte;
X function WhereY: Byte;
X
X procedure ClrScr;
X procedure ClrEol;
X
X procedure NormalVideo;
X procedure ReverseVideo;
X procedure BlinkVideo;
X
X
X (* -------------------------------------------------------- *)
X procedure ScrollUp;
X {$F+} function ConFlush(var F: TextRec): integer; {$F-}
X {$F+} function ConOutput(var F: TextRec): integer; {$F-}
X {$F+} function ConOpen(var F: TextRec): Integer; {$F-}
X
X
X(* -------------------------------------------------------- *)
Ximplementation
X
X const
X window_y1 : byte = 1;
X window_y2 : byte = 25;
X TextAttr : byte = $0f;
X key_pending: char = #0;
X
X
X (* -------------------------------------------------------- *)
X function ReadKey: Char;
X var
X reg: registers;
X begin
X if key_pending <> #0 then
X begin
X ReadKey := key_pending;
X key_pending := #0;
X exit;
X end;
X
X reg.ax := $0100; {check for character}
X intr($16,reg);
X if (reg.flags and FZero) = 0 then
X begin
X reg.ax := $0000; {wait for character}
X intr($16,reg);
X if reg.al = 0 then
X key_pending := chr(reg.ah);
X end
X else
X
X begin
X reg.ax := $0700; {direct console input}
X msdos(reg);
X end;
X
X ReadKey := chr(reg.al);
X end;
X
X
X (* -------------------------------------------------------- *)
X function KeyPressed: Boolean;
X var
X reg: registers;
X begin
X reg.ax := $0b00; {ConInputStatus}
X msdos(reg);
X KeyPressed := (reg.al = $FF) or (key_pending <> #0);
X end;
X
X
X (* -------------------------------------------------------- *)
X procedure Window(X1,Y1,X2,Y2: Byte);
X begin
X window_y1 := y1;
X window_y2 := y2;
X end;
X
X
X (* -------------------------------------------------------- *)
X procedure GotoXY(X,Y: Byte);
X var
X reg: registers;
X begin
X reg.ah := 2; {set cursor position}
X reg.bh := 0; {page}
X reg.dh := y-1;
X reg.dl := x-1;
X intr($10,reg);
X end;
X
X
X (* -------------------------------------------------------- *)
X function WhereX: Byte;
X var
X reg: registers;
X begin
X reg.ah := 3;
X reg.bh := 0;
X intr($10,reg);
X WhereX := reg.dl+1;
X end;
X
X function WhereY: Byte;
X var
X reg: registers;
X begin
X reg.ah := 3;
X reg.bh := 0;
X intr($10,reg);
X WhereY := reg.dh+1;
X end;
X
X
X (* -------------------------------------------------------- *)
X procedure ClrScr;
X var
X reg: registers;
X begin
X reg.ax := $0600; {scroll up, blank window}
X reg.cx := 0; {upper left}
X reg.dx := $194F; {line 24, col 79}
X reg.bh := TextAttr;
X intr($10,reg);
X GotoXY(1,1);
X end;
X
X
X (* -------------------------------------------------------- *)
X procedure ClrEol;
X var
X reg: registers;
X begin
X reg.ax := $0600; {scroll up, blank window}
X reg.ch := wherey-1;
X reg.cl := wherex-1;
X reg.dh := reg.ch;
X reg.dl := 79; {lower column}
X reg.bh := TextAttr;
X intr($10,reg);
X end;
X
X
X (* -------------------------------------------------------- *)
X procedure NormalVideo;
X begin
X TextAttr := $0f;
X end;
X
X procedure ReverseVideo;
X begin
X TextAttr := $70;
X end;
X
X procedure BlinkVideo;
X begin
X TextAttr := $F0;
X end;
X
X
X (* -------------------------------------------------------- *)
X procedure ScrollUp;
X var
X reg: registers;
X begin
X reg.ah := 6; {scroll up}
X reg.al := 1; {lines}
X reg.cx := 0; {upper left}
X reg.dh := window_y2-1; {lower line}
X reg.dl := 79; {lower column}
X reg.bh := TextAttr;
X intr($10,reg);
X end;
X
X
X (* -------------------------------------------------------- *)
X {$F+} function ConFlush(var F: TextRec): integer; {$F-}
X var
X P: Word;
X reg: registers;
X x,y: byte;
X
X begin
X {get present cursor position}
X reg.ah := 3;
X reg.bh := 0;
X intr($10,reg);
X y := reg.dh+1;
X x := reg.dl+1;
X
X {process each character in the buffer}
X P := 0;
X while P < F.BufPos do
X begin
X reg.al := ord(F.BufPtr^[P]);
X
X case reg.al of
X 7: write(stdout,^G);
X
X 10: if y >= window_y2 then {scroll when needed}
X ScrollUp
X else
X inc(y);
X
X 13: x := 1;
X
X else
X begin
X reg.ah := 9; {display character with TextAttr}
X reg.bx := 0; {... does not move the cursor}
X reg.cx := 1;
X reg.bl := TextAttr;
X intr($10,reg);
X
X if x = 80 then {line wrap?}
X begin
X x := 1;
X if y >= window_y2 then {scroll during wrap?}
X ScrollUp
X else
X inc(y);
X end
X else
X inc(x);
X end;
X end;
X
X {position physical cursor}
X reg.ah := 2; {set cursor position}
X reg.bh := 0; {page}
X reg.dh := y-1;
X reg.dl := x-1;
X intr($10,reg);
X
X inc(P);
X end;
X
X F.BufPos:=0;
X ConFlush := 0;
X end;
X
X
X {$F+} function ConOutput(var F: TextRec): integer; {$F-}
X begin
X ConOutput := ConFlush(F);
X end;
X
X
X {$F+} function ConOpen(var F: TextRec): Integer; {$F-}
X begin
X F.InOutFunc := @ConOutput;
X F.FlushFunc := @ConFlush;
X F.CloseFunc := @ConFlush;
X F.BufPos := 0;
X ConOpen := 0;
X end;
X
X
X (* -------------------------------------------------------- *)
Xvar
X e: integer;
X
Xbegin
X
X{$IFDEF DEBUGGING}
X writeln('minicrt init');
X{$ENDIF}
X
X with TextRec(output) do
X begin
X InOutFunc := @ConOutput;
X FlushFunc := @ConFlush;
X OpenFunc := @ConOpen;
X BufPos := 0;
X end;
X
X {error #18 has been reported here when operating under desqview}
X {what is 18, anyway??}
X assign(stdout,'');
X {$i-} rewrite(stdout); {$i+}
X e := ioresult;
X if e <> 0 then
X writeln('[error ',e,' on stdout]');
Xend.
X
________This_Is_The_END________
if test `wc -c < minicrt.pas` -ne 6778; then
echo 'shar: minicrt.pas was damaged during transit (should have been 6778 bytes)'
fi
fi ; : end of overwriting check
echo 'x - mtplus.pas'
if test -f mtplus.pas; then echo 'shar: not overwriting mtplus.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > mtplus.pas
X
X(*
X * Example of PASCAL/MT+
X *)
X
XMODULE MENUS;
X
XCONST
X{$I MENUS.CON}
X
XVAR
X DUMMY_B: BOOLEAN;
X DATE: STRING[12];
X REVS: BYTE;
X WAIT_PERIOD: LONGINT;
X S: STRING; {default length?}
X IN_TOP_LEVEL: EXTERNAL BOOLEAN;
X MNS: EXTERNAL ARRAY [1..200] OF STRING[40];
X L_MARGIN: EXTERNAL BYTE;
X
X (*------- notice the external declaration -------*)
X
X EXTERNAL PROCEDURE PUTCHRS(CH: CHAR ; CNT: INTEGER);
X EXTERNAL FUNCTION WAIT_FOR_CHAR: CHAR;
X EXTERNAL FUNCTION GET_CHR_AND_MESSAGES: CHAR;
X EXTERNAL FUNCTION SYS_TICK: LONGINT;
X EXTERNAL PROCEDURE ANSWER;
X
X (*------- notice the external declaration in an overlay #1 -------*)
X
X EXTERNAL [1] PROCEDURE EDIT;
X EXTERNAL [2] PROCEDURE PREPARE;
X EXTERNAL [2] PROCEDURE SAVE_SYS_PARMS;
X EXTERNAL [5] PROCEDURE LOAD_MSG;
X EXTERNAL [5] PROCEDURE SAVE_MSG;
X EXTERNAL [5] PROCEDURE KILL_MSG;
X EXTERNAL [5] PROCEDURE VIEW_MSG;
X
XPROCEDURE SET_DATE(S: STRING);
XBEGIN
X DATE := S;
X ATTR := HILT;
X XYGOTO(60,1);
X WRITE([ADDR(PUT_CHR)],DATE);
X ATTR := NORMAL;
XEND;
X
XPROCEDURE SWITCH(CH: CHAR);
XBEGIN
X C := (C & $FF00) ! ORD(CH);
X (*---- ^ this is a bit-wise OR ----*)
X (*---- ^ this is a bit-wise AND ----*)
XEND;
X
X{$E-}
X{$E+}
X
XMODEND.
________This_Is_The_END________
if test `wc -c < mtplus.pas` -ne 1300; then
echo 'shar: mtplus.pas was damaged during transit (should have been 1300 bytes)'
fi
fi ; : end of overwriting check
echo 'x - point4.pas'
if test -f point4.pas; then echo 'shar: not overwriting point4.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > point4.pas
X
X(*
X * Another example of pointer manipulation
X *
X *)
X
Xtype
X Int_Point = ^Integer;
X
Xvar
X Index : Integer;
X Where : ^Integer;
X Who : ^Integer;
X Pt1, Pt2, Pt3 : Int_Point;
X
Xbegin
X Index := 17;
X Where := @Index;
X Who := @Index;
X Writeln('The values are ',Index:5,Where^:5,Who^:5);
X
X Where^ := 23;
X Writeln('The values are ',Index:5,Where^:5,Who^:5);
X
X Pt1 := @Index;
X Pt2 := Pt1;
X Pt3 := Pt2;
X Pt2^ := 151;
X Writeln('The Pt values are',Pt1^:5,Pt2^:5,Pt3^:5);
Xend.
________This_Is_The_END________
if test `wc -c < point4.pas` -ne 531; then
echo 'shar: point4.pas was damaged during transit (should have been 531 bytes)'
fi
fi ; : end of overwriting check
echo 'x - pointers.pas'
if test -f pointers.pas; then echo 'shar: not overwriting pointers.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > pointers.pas
X(*
X * Examples of pointer manipulation
X *
X *)
X
Xprogram Pointer_Use_Example;
X
Xtype
X Name = string[20];
X
Xvar
X My_Name : ^Name; (* My_Name is a pointer to a string[20] *)
X My_Age : ^integer; (* My_Age is a pointer to an integer *)
X
Xbegin
X New(My_Name);
X New(My_Age);
X
X My_Name^ := 'John Q Doe';
X My_Age^ := 27;
X
X Writeln('My name is ',My_Name^);
X Writeln('My age is ',My_Age^:3);
X
X Dispose(My_Name);
X Dispose(My_Age);
Xend.
________This_Is_The_END________
if test `wc -c < pointers.pas` -ne 451; then
echo 'shar: pointers.pas was damaged during transit (should have been 451 bytes)'
fi
fi ; : end of overwriting check
echo 'x - puzzle.pas'
if test -f puzzle.pas; then echo 'shar: not overwriting puzzle.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > puzzle.pas
X
X(*
X * Example of multi-dimensional array manipulation
X *)
X
Xprogram Puzzle;
X
Xconst
X XSize = 511; { d*d*d-1}
X ClassMax = 3;
X TypeMax = 12;
X D = 8;
X
Xtype
X PieceClass = 0..ClassMax;
X PieceType = 0..TypeMax;
X Position = 0..XSize;
X
Xvar
X PieceCount : array[PieceClass] of 0..13;
X Class : array[PieceType] of PieceClass;
X PieceMax : array[PieceType] of Position;
X Puzzle : array[Position] of Boolean;
X P : array[PieceType] of array[Position] of Boolean;
X P2 : array[PieceType,Position] of Boolean; {alternate form}
X M, N : Position;
X I, J, K : 0..13;
X Kount : Integer;
X
X function Fit(I : PieceType; J : Position) : Boolean;
X label 1;
X var
X K : Position;
X begin
X Fit := False;
X for K := 0 to PieceMax[I] do
X if P[I, K] then
X if Puzzle[J+K] then
X goto 1;
X Fit := True;
X1:
X end;
X
X function Place(I : PieceType; J : Position) : Position;
X label
X 1;
X var
X K : Position;
X begin
X for K := 0 to PieceMax[I] do
X if P[I, K] then
X Puzzle[J+K] := True;
X PieceCount[Class[I]] := PieceCount[Class[I]]-1;
X for K := J to XSize do
X if not Puzzle[K] then
X begin
X Place := K;
X goto 1;
X end;
X WriteLn('Puzzle filled');
X Place := 0;
X1:
X end;
X
X procedure Remove(I : PieceType; J : Position);
X var
X K : Position;
X begin
X for K := 0 to PieceMax[I] do
X if P[I, K] then
X Puzzle[J+K] := False;
X PieceCount[Class[I]] := PieceCount[Class[I]]+1;
X end;
X
X function Trial(J : Position) : Boolean;
X var
X I : PieceType;
X K : Position;
X begin
X for I := 0 to TypeMax do
X if PieceCount[Class[I]] <> 0 then
X if Fit(I, J) then
X begin
X K := Place(I, J);
X if Trial(K) or (K = 0) then
X begin
X {writeln( 'Piece', i + 1, ' at', k + 1);}
X Trial := True;
X exit;
X end
X else
X Remove(I, J);
X end;
X Trial := False;
X Kount := Kount+1;
X end;
X
Xbegin
X WriteLn('Solving puzzle...');
X for M := 0 to XSize do
X Puzzle[M] := True;
X for I := 1 to 5 do
X for J := 1 to 5 do
X for K := 1 to 5 do
X Puzzle[I+D*(J+D*K)] := False;
X
X for I := 0 to TypeMax do
X for M := 0 to XSize do
X P[I, M] := False;
X
X for I := 0 to 3 do
X for J := 0 to 1 do
X for K := 0 to 0 do
X P[0, I+D*(J+D*K)] := True;
X
X Class[0] := 0;
X PieceMax[0] := 3+D*1+D*D*0;
X for I := 0 to 1 do
X for J := 0 to 0 do
X for K := 0 to 3 do
X P[1, I+D*(J+D*K)] := True;
X
X Class[1] := 0;
X PieceMax[1] := 1+D*0+D*D*3;
X for I := 0 to 0 do
X for J := 0 to 3 do
X for K := 0 to 1 do
X P[2, I+D*(J+D*K)] := True;
X
X Class[2] := 0;
X PieceMax[2] := 0+D*3+D*D*1;
X for I := 0 to 1 do
X for J := 0 to 3 do
X for K := 0 to 0 do
X P[3, I+D*(J+D*K)] := True;
X
X Class[3] := 0;
X PieceMax[3] := 1+D*3+D*D*0;
X for I := 0 to 3 do
X for J := 0 to 0 do
X for K := 0 to 1 do
X P[4, I+D*(J+D*K)] := True;
X
X Class[4] := 0;
X PieceMax[4] := 3+D*0+D*D*1;
X for I := 0 to 0 do
X for J := 0 to 1 do
X for K := 0 to 3 do
X P[5, I+D*(J+D*K)] := True;
X
X Class[5] := 0;
X PieceMax[5] := 0+D*1+D*D*3;
X for I := 0 to 2 do
X for J := 0 to 0 do
X for K := 0 to 0 do
X P[6, I+D*(J+D*K)] := True;
X
X Class[6] := 1;
X PieceMax[6] := 2+D*0+D*D*0;
X for I := 0 to 0 do
X for J := 0 to 2 do
X for K := 0 to 0 do
X P[7, I+D*(J+D*K)] := True;
X
X Class[7] := 1;
X PieceMax[7] := 0+D*2+D*D*0;
X for I := 0 to 0 do
X for J := 0 to 0 do
X for K := 0 to 2 do
X P[8, I+D*(J+D*K)] := True;
X
X Class[8] := 1;
X PieceMax[8] := 0+D*0+D*D*2;
X for I := 0 to 1 do
X for J := 0 to 1 do
X for K := 0 to 0 do
X P[9, I+D*(J+D*K)] := True;
X
X Class[9] := 2;
X PieceMax[9] := 1+D*1+D*D*0;
X for I := 0 to 1 do
X for J := 0 to 0 do
X for K := 0 to 1 do
X P[10, I+D*(J+D*K)] := True;
X
X Class[10] := 2;
X PieceMax[10] := 1+D*0+D*D*1;
X for I := 0 to 0 do
X for J := 0 to 1 do
X for K := 0 to 1 do
X P[11, I+D*(J+D*K)] := True;
X
X Class[11] := 2;
X PieceMax[11] := 0+D*1+D*D*1;
X for I := 0 to 1 do
X for J := 0 to 1 do
X for K := 0 to 1 do
X P[12, I+D*(J+D*K)] := True;
X
X Class[12] := 3;
X PieceMax[12] := 1+D*1+D*D*1;
X PieceCount[0] := 13;
X PieceCount[1] := 3;
X PieceCount[2] := 1;
X PieceCount[3] := 1;
X M := 1+D*(1+D*1);
X Kount := 0;
X
X if Fit(0, M) then
X N := Place(0, M)
X else
X WriteLn(' error 1');
X
X if Trial(N) then
X WriteLn(' success in ', Kount, ' trials')
X else
X WriteLn(' failure');
Xend.
________This_Is_The_END________
if test `wc -c < puzzle.pas` -ne 4577; then
echo 'shar: puzzle.pas was damaged during transit (should have been 4577 bytes)'
fi
fi ; : end of overwriting check
echo 'x - qsort.pas'
if test -f qsort.pas; then echo 'shar: not overwriting qsort.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > qsort.pas
X
X(*
X * Non-recursive quick sort
X *)
X
Xprogram QuickSort;
X
Xconst
X N = 15000;
X StackSize = 60;
X InsertParam = 20;
Xtype
X Index = 0..N;
Xvar
X L, R, I, J, M : Index;
X V, T : Integer;
X S : 0..StackSize;
X Stack : array[1..StackSize] of record
X L, R : Index;
X end;
X A : array[Index] of Integer;
X
Xbegin { qsort}
X WriteLn('Non-recursive QuickSort...');
X for I := 1 to N do
X A[I] := I mod 500;
X A[0] := -MaxInt;
X S := 1;
X Stack[1].L := 1;
X Stack[1].R := N;
X repeat
X L := Stack[S].L;
X R := Stack[S].R;
X S := S-1;
X while R-L > InsertParam do
X begin
X M := (L+R) div 2;
X T := A[M];
X A[M] := A[L+1];
X A[L+1] := T;
X if A[L+1] > A[R] then
X begin
X T := A[L+1];
X A[L+1] := A[R];
X A[R] := T;
X end;
X if A[L] > A[R] then
X begin
X T := A[L];
X A[L] := A[R];
X A[R] := T;
X end;
X if A[L+1] > A[L] then
X begin
X T := A[L+1];
X A[L+1] := A[L];
X A[L] := T;
X end;
X I := L+1;
X J := R;
X V := A[L];
X repeat
X repeat
X I := I+1;
X until A[I] >= V;
X repeat
X J := J-1;
X until A[J] <= V;
X if I < J
X then begin
X T := A[I];
X A[I] := A[J];
X A[J] := T;
X end;
X until I > J;
X A[L] := A[J];
X A[J] := V;
X S := S+1;
X if I-L < R-I then
X begin
X Stack[S].L := I;
X Stack[S].R := R;
X R := J-1;
X end
X else
X begin
X Stack[S].L := L;
X Stack[S].R := J-1;
X L := I;
X end;
X end;
X until S = 0;
X
X for L := 1 to N-1 do
X begin
X if A[L] > A[L+1] then
X begin
X V := A[L+1];
X I := L;
X repeat
X A[I+1] := A[I];
X I := I-1;
X until A[I] <= V;
X A[I+1] := V;
X end;
X end;
X
X WriteLn('finished');
Xend.
________This_Is_The_END________
if test `wc -c < qsort.pas` -ne 2131; then
echo 'shar: qsort.pas was damaged during transit (should have been 2131 bytes)'
fi
fi ; : end of overwriting check
echo 'x - readme'
if test -f readme; then echo 'shar: not overwriting readme'; else
sed 's/^X//' << '________This_Is_The_END________' > readme
X
X
X
X TPTC - Turbo Pascal to C translator
X Version 1.7, 25-Mar-88
X
X Copyright 1988 Samuel H. Smith; ALL RIGHTS RESERVED
X
X
X These files are distributed under the SourceWare concept.
X Do not distribute modified versions without my permission.
X Do not use any of this in a commercial product.
X Do not remove this notice or any other copyright notice.
X
X
X
X
XTptc is delivered in three archives:
X
XTPTC17.ARC 67244 03-26-88 Translate Pascal to C. Exe+DOC files. v1.7
X This is the main distribution archive. It contains the
X translator, documentation and a few supporting files. See
X HISTORY.DOC for the revision history, including changes since
X the manual was last updated. See TODO.DOC for a list of changes
X that are planned in the near future.
X
XTPTC17SC.ARC 63947 03-26-88 Full Source Code for TPTC. SourceWare. v1.7
X This is the complete source code for TPTC. This is distributed
X under the SourceWare concept. See the file LICENSE.DOC for
X details.
X
XTPTC17TC.ARC 34428 03-26-88 A number of Test Cases for TPTC. v1.7
X This archive contains a number of "test cases" used to verify
X the operation of TPTC. New test cases are added as the
X translator development proceeds.
X
X
X
X
X
X
X
X DISCLAIMER
X ==========
X
X IN NO EVENT WILL I BE LIABLE TO YOU FOR ANY DAMAGES, INCLUDING ANY
X LOST PROFITS, LOST SAVINGS OR OTHER INCIDENTAL OR CONSEQUENTIAL
X DAMAGES ARISING OUT OF YOUR USE OR INABILITY TO USE THE PROGRAM, OR
X FOR ANY CLAIM BY ANY OTHER PARTY.
X
X
X
X
X
X
X
X
X
X
X ----------------
X Turbo Pascal is a registered trademark of Borland International.
X
X
X LICENSE
X =======
X SourceWare: What is it?
X -----------------------
X SourceWare is my name for a unique concept in user supported
X software.
X
X Programs distributed under the SourceWare concept always offer
X complete source code.
X
X This package can be freely distributed so long as it is not modified
X or sold for profit. If you find that this program is valuable, you
X can send me a donation for what you think it is worth. I suggest
X about $20. The donation is manditory if you are using this program
X in a comercial setting.
X
X Send your contributions to:
X Samuel. H. Smith
X 5119 N. 11 ave 332
X Phoenix, Az 85013
X
X
X Why SourceWare?
X ---------------
X Why do I include source code? The value of good software should be
X self-evident. The source code is the key to complete understanding
X of a program. You can read it to find out how things are done. You
X can also change it to suit your needs, so long as you do not
X distribute the modified version without my consent.
X
X
X Copyright
X ---------
X If you modify this program, I would appreciate a copy of the new
X source code. I am holding the copyright on the source code, so
X please don't delete my name from the program files or from the
X documentation.
X
X
X SUPPORT
X =======
X
X I work very hard to produce a software package of the highest
X quality and functionality. I try to look into all reported bugs,
X and will generally fix reported problems within a few days.
X
X Since this is user supported software under the SourceWare concept,
X I don't expect you to contribute if you don't like it or if it
X doesn't meet your needs.
X
X If you have any questions, bugs, or suggestions, please contact me
X at:
X The Tool Shop BBS
X (602) 279-2673
X
X The latest version is always available for downloading.
X
X Enjoy! Samuel H. Smith
X Author and Sysop of The Tool Shop.
X
________This_Is_The_END________
if test `wc -c < readme` -ne 3939; then
echo 'shar: readme was damaged during transit (should have been 3939 bytes)'
fi
fi ; : end of overwriting check
echo 'x - sets.pas'
if test -f sets.pas; then echo 'shar: not overwriting sets.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > sets.pas
X
X(*
X * Examples of set manipulation
X *
X *)
X
Xprogram Define_Some_Sets;
X
Xtype
X Goodies = (Ice_Cream,Whipped_Cream,Banana,Nuts,Cherry,
X Choc_Syrup,Strawberries,Caramel,Soda_Water,
X Salt,Pepper,Cone,Straw,Spoon,Stick);
X
X Treat = set of Goodies;
X
Xvar
X Sundae : Treat;
X Banana_Split : Treat;
X Soda : Treat;
X Ice_Cream_Cone : Treat;
X Nutty_Buddy : Treat;
X Mixed : Treat;
X Index : byte;
X
Xbegin
X (* define all ingredients used in each treat *)
X Ice_Cream_Cone := [Ice_Cream,Cone];
X Soda := [Straw,Soda_Water,Ice_Cream,Cherry];
X Banana_Split := [Ice_Cream..Caramel];
X Banana_Split := Banana_Split + [Spoon];
X Nutty_Buddy := [Cone,Ice_Cream,Choc_Syrup,Nuts];
X Sundae := [Ice_Cream,Whipped_Cream,Nuts,Cherry,Choc_Syrup,
X Spoon];
X
X (* combine for a list of all ingredients used *)
X
X Mixed := Ice_Cream_Cone + Soda + Banana_Split + Nutty_Buddy +
X Sundae;
X Mixed := [Ice_Cream..Stick] - Mixed; (* all ingredients not used *)
X
X if Ice_Cream in Mixed then Writeln('Ice cream not used');
X if Whipped_Cream in Mixed then Writeln('Whipped cream not used');
X if Banana in Mixed then Writeln('Bananas not used');
X if Nuts in Mixed then Writeln('Nuts are not used');
X if Cherry in Mixed then Writeln('Cherrys not used');
X if Choc_Syrup in Mixed then Writeln('Chocolate syrup not used');
X if Strawberries in Mixed then Writeln('Strawberries not used');
X if Caramel in Mixed then Writeln('Caramel is not used');
X if Soda_Water in Mixed then Writeln('Soda water is not used');
X if Salt in Mixed then Writeln('Salt not used');
X if Pepper in Mixed then Writeln('Pepper not used');
X if Cone in Mixed then Writeln('Cone not used');
X if Straw in Mixed then Writeln('Straw not used');
X if Spoon in Mixed then Writeln('Spoon not used');
X if Stick in Mixed then Writeln('Stick not used');
Xend.
________This_Is_The_END________
if test `wc -c < sets.pas` -ne 2060; then
echo 'shar: sets.pas was damaged during transit (should have been 2060 bytes)'
fi
fi ; : end of overwriting check
exit 0
More information about the Comp.sources.misc
mailing list