v04i027: Turbo Pascal to C -- TEST CASES, part 2/2
Alan Strassberg
alan at leadsv.UUCP
Mon Aug 15 08:59:23 AEST 1988
Posting-number: Volume 4, Issue 27
Submitted-by: "Alan Strassberg" <alan at leadsv.UUCP>
Archive-name: tptctest/Part2
[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 753 Aug 14 17:08 sieve.pas
# -rw-r--r-- 1 allbery System 831 Aug 14 17:08 smallrec.pas
# -rw-r--r-- 1 allbery System 974 Aug 14 17:08 subrange.pas
# -rw-r--r-- 1 allbery System 4777 Aug 14 17:09 test.pas
# -rw-r--r-- 1 allbery System 1579 Aug 14 17:09 test2.pas
# -rw-r--r-- 1 allbery System 399 Aug 14 17:09 timedat4.pas
# -rw-r--r-- 1 allbery System 22554 Aug 14 17:09 unsq.pas
# -rw-r--r-- 1 allbery System 2009 Aug 14 17:09 varrec.pas
#
echo 'x - sieve.pas'
if test -f sieve.pas; then echo 'shar: not overwriting sieve.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > sieve.pas
X
X(*
X * Sieve of Eratosthenes
X *)
X
Xprogram Sieve;
X
Xconst
X Size = 8190;
Xvar
X Flags : array[0..Size] of Boolean;
X Prime, K, Count : Integer;
X Inter, I : Integer;
X
Xbegin
X WriteLn('Sieve of Eratosthenes...');
X Write('50 iterations');
X WriteLn;
X for Inter := 1 to 50 do
X begin
X Count := 0;
X for I := 0 to Size do
X Flags[I] := True;
X for I := 0 to Size do
X begin
X if (Flags[I]) then
X begin
X Prime := I+I+3;
X K := I+Prime;
X while (K <= Size) do
X begin
X Flags[K] := False;
X K := K+Prime;
X end;
X Count := Count+1;
X end;
X end;
X end;
X WriteLn(Count, ' primes');
Xend.
________This_Is_The_END________
if test `wc -c < sieve.pas` -ne 753; then
echo 'shar: sieve.pas was damaged during transit (should have been 753 bytes)'
fi
fi ; : end of overwriting check
echo 'x - smallrec.pas'
if test -f smallrec.pas; then echo 'shar: not overwriting smallrec.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > smallrec.pas
X
X(*
X * Example of array subscripting
X *)
X
Xprogram A_Small_Record;
X
Xtype
X Description = record
X Year : integer;
X Model : string[20];
X Engine : string[8];
X end;
X
Xvar
X Cars : array[1..10] of Description;
X Index : integer;
X
Xbegin (* main program *)
X for Index := 1 to 10 do begin
X Cars[Index].Year := 1930 + Index; {should be ...[index-1]}
X Cars[Index].Model := 'Duesenburg';
X Cars[Index].Engine := 'V8';
X end;
X
X Cars[2].Model := 'Stanley Steamer';
X Cars[2].Engine := 'Coal';
X Cars[7].Engine := 'V12';
X Cars[9].Model := 'Ford';
X Cars[9].Engine := 'rusted';
X
X for Index := 1 to 10 do begin
X Write('My ',Cars[Index].Year:4,' ');
X Write(Cars[Index].Model,' has a ');
X Writeln(Cars[Index].Engine,' engine.');
X end;
Xend. (* of main program *)
________This_Is_The_END________
if test `wc -c < smallrec.pas` -ne 831; then
echo 'shar: smallrec.pas was damaged during transit (should have been 831 bytes)'
fi
fi ; : end of overwriting check
echo 'x - subrange.pas'
if test -f subrange.pas; then echo 'shar: not overwriting subrange.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > subrange.pas
X
X(*
X * Example of character and enumeration subrange types
X *)
X
Xprogram Scaler_Operations;
X
Xtype
X Days = (Mon,Tue,Wed,Thu,Fri,Sat,Sun);
X Work = Mon..Fri;
X Rest = Sat..Sun;
X
Xvar
X Day : Days; (* This is any day of the week *)
X Workday : Work; (* These are the the working days *)
X Weekend : Rest; (* The two weekend days only *)
X Index : 1..12;
X Alphabet : 'a'..'z';
X Start : 'a'..'e';
X
Xbegin (* main program *)
X Workday := Tue;
X Weekend := Sat;
X Day := Workday;
X Day := Weekend;
X Index := 3+2*2;
X Start := 'd';
X Alphabet := Start;
X (* since Alphabet is "d" *)
X Start := Succ(Alphabet); (* Start will be 'e' *)
X Start := Pred(Alphabet); (* Start will be 'c' *)
X Day := Wed;
X Day := Succ(Day); (* Day will now be 'Thu' *)
X Day := Succ(Day); (* Day will now be 'Fri' *)
X Index := Ord(Day); (* Index will be 4 (Fri = 4) *)
Xend. (* of main program *)
________This_Is_The_END________
if test `wc -c < subrange.pas` -ne 974; then
echo 'shar: subrange.pas was damaged during transit (should have been 974 bytes)'
fi
fi ; : end of overwriting check
echo 'x - test.pas'
if test -f test.pas; then echo 'shar: not overwriting test.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > test.pas
X
X(*
X * This program demonstrates some weaknesses in TPC 1.4 and TPC 1.5. Unless
X * otherwise noted, all failed translations are in 1.4 and corrected in 1.5.
X *
X *)
X
Xprogram Test;
X
Xvar
X vector : Integer absolute $0000:$03c4;
X (* absolute variables not translated in tpc 1.5 *)
X
X Ch : Char;
X IbmAt : Boolean;
X Control : Boolean;
X
Xtype
X Longstring = string[255];
X
X Lookup = Array[1..7,0..1] of integer;
X (* multi-dimension array declarations not translated
X in tpc 1.5 *)
X
X NestedArray = Array[1..7] of array[0..1] of integer;
X (* nested arrays not translated in tpc 1.5 *)
X
X mytype1 = char;
X mytype2 = byte;
X mytype3 = integer;
X mytype4 = string[80];
X
X myrec = record
X astr: longstring;
X areal: real;
X aint: integer;
X achar: char;
X end;
X
Xconst
X tab : Lookup = { this goes haywire here }
X ((10,824), (9,842), (9,858), (9,874),
X (10,890), (9,908), (9,924));
X
Xprocedure InvVid(m: longstring); {added}
Xbegin
X writeln(m);
Xend;
X
Xprocedure call_a;
Xvar
X s1,s2: string;
Xbegin
X s1 := 'filename';
X s2 := '#include "' + s1 + '" ';
Xend;
X
Xprocedure call_b(L : Integer;
X table : Lookup);
Xconst
X seg_addr = $0040; {constants added}
X filter_ptr = $200;
X Vert = '|';
X Dbl = '==';
X
Xbegin
X Write(Memw[seg_addr : Filter_Ptr] + 1); GotoXY(4,4);
X GotoXY(4,11);
X
X{ put this next line in blows up in 1.4 -- }
X InvVid(Vert+' Retrieve '+Dbl+' Save '+Dbl+
X ' Combine '+Dbl+' Xtract '+Dbl+' Erase '+
X Dbl+' List '+Dbl+' Import '+Dbl+
X ' Directory '+ Vert);
Xend;
X
Xprocedure UsesUntyped( width: integer;
X var base; {untyped}
X size: integer );
Xvar
X buf: array[1..1000] of byte absolute base;
X (* absolutes not translated in 1.6 *)
X i: integer;
Xbegin
X for i := 1 to size do
X writeln(i,': ',buf[i]:width);
Xend;
X
X
Xprocedure myprocmess(var v1, v2, v3);
X {untyped params not translated in tpc1.5}
Xvar
X xv1: mytype1 absolute v1;
X xv2: mytype2 absolute v2;
X xv3: mytype3 absolute v3;
X xv4: mytype4 absolute v3; (* this is the dirtiest of the lot *)
X {absolute variables not translated in tpc1.5}
X othvar1: integer;
X othvar2: char;
X
Xbegin
X othvar1 := xv1;
X othvar2 := xv2;
X othvar1 := xv3;
X othvar2 := xv4;
X {implicit conversion of absolute variables to
X pointer deref's produced by tptc1.6}
Xend;
X
Xprocedure varparams(var i: integer;
X var r: real;
X var s: string);
Xbegin
X i := 100;
X r := 100.1;
X s := 'some string';
X s[5] := '!';
Xend;
X
X
Xprocedure test_untyped;
Xvar
X r: real;
X i: integer;
X s: string;
Xbegin
X r := 1.2;
X i := 99;
X s := 'some string';
X myprocmess(r,i,s);
X
X UsesUntyped( 10, s, 2);
X UsesUntyped( 8, r, 3);
X UsesUntyped( 2, i, 3);
X
X varparams(i,r,s);
X
X str(r:3:1,s); {should generate sbld call}
X val(s,r,i); {should pass address of r and i}
Xend;
X
Xprocedure testrec;
Xvar
X rec1: myrec;
X rec2: myrec;
Xconst
X limit = 1000;
Xbegin
X rec1.astr := 'some string';
X rec1.astr[5] := '-';
X rec1.areal := 1.23;
X rec1.achar := 'x';
X rec1.aint := limit;
X writeln('str=',rec1.astr,' r=',rec1.areal,' i=',rec1.aint,' c=',rec1.achar);
X rec2 := rec1;
Xend;
X
Xprocedure test_nesting(outerpar: integer);
Xconst
X limit = 2000; {clashes with testrec's limit?}
Xvar
X outervar: integer;
X
X procedure inner;
X {outer version of inner}
X
X procedure inner;
X {name will clash with outer version of inner}
X begin
X outervar := 1;
X {inmost}
X end;
X
X var
X innervar: integer;
X begin
X inner; {outer version of inner}
X innervar := outerpar;
X outervar := innervar + limit;
X end;
X
Xbegin
X inner;
X outervar := outerpar;
X write(^M^J'This wouldn''t translate in tpc1.5!');
X write(^M^J'This wouldn''t translate in tpc1.5!'^M^J);
X write('This wouldn''t translate in tpc1.5!'^M^J);
Xend;
X
Xprocedure main_block;
Xbegin
X if Mem[$ffff:$0e] = $FC then
X begin
X IbmAt := True;
X end;
X
X Repeat
X if IbmAt then
X begin
X Control := True;
X end
X else
X
X case Ch of
X '1'..'8': call_a; { 1.4 fails to put in cases from 2 to 7 }
X 'Z' : call_a;
X 'z' : begin end; { do nothing }
X else
X { Do Nothing }
X end;
X
X Until (Ch = Chr(13)) OR (Ch = 'Z');
Xend;
X
X
X
Xbegin
X (* main block *)
X main_block;
Xend.
X
________This_Is_The_END________
if test `wc -c < test.pas` -ne 4777; then
echo 'shar: test.pas was damaged during transit (should have been 4777 bytes)'
fi
fi ; : end of overwriting check
echo 'x - test2.pas'
if test -f test2.pas; then echo 'shar: not overwriting test2.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > test2.pas
X
XProgram test;
X
X{test source for tptc's translation of declarations}
X
X Type
X CompDataRec = Record
X Opr : Byte; { Operator }
X Case T : Integer Of
X 0 : (Dat1, Dat2 : Integer);
X 1 : (Str1, Str2 : Byte);
X 2 : (Byt1, Byt2 : Byte);
X 3 : (Int1, Int2 : Integer);
X 4 : (Real1, Real2 : Real);
X 5, 6 : (Bool1, Bool2 : Boolean);
X End;
X
X DateRec = Record
X Year : Integer;
X Month : Integer;
X Day : Integer;
X End;
X
X BuffTyp = Record
X Status : Integer;
X Name1 : Integer;
X name2 : Integer;
X name3 : Boolean;
X name4 : Integer;
X name5 : Real;
X name6 : Real;
X name7 : Array[1..3] Of Integer;
X Birth : DateRec;
X LastIn : DateRec;
X Recall : DateRec;
X End;
X
X
X Procedure ClearBuff(Var Buff : BuffTyp;
X RecN : Integer);
X Const
X BlankBuf : BuffTyp =
X (Status : 0;
X Name1 : 0;
X name2 : 0;
X name3 : False;
X name4 : 0;
X name5 : 0.0;
X name6 : 0.0;
X name7 : (1, 0, 0);
X Birth : (Year : 0; Month : 0; Day : 0);
X LastIn : (Year : 0; Month : 0; Day : 0);
X Recall : (Year : 0; Month : 0; Day : 0));
X Begin
X {body of clearbuff}
X Buff := BlankBuf;
X End;
X
X Begin
X {main block}
X End.
X
________This_Is_The_END________
if test `wc -c < test2.pas` -ne 1579; then
echo 'shar: test2.pas was damaged during transit (should have been 1579 bytes)'
fi
fi ; : end of overwriting check
echo 'x - timedat4.pas'
if test -f timedat4.pas; then echo 'shar: not overwriting timedat4.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > timedat4.pas
X
X(*
X * Example of tpas4.0 WORD data type
X *)
X
Xprogram Get_Time_And_Date;
X
Xuses Dos;
X
Xvar
X Year,Month,Day,Weekday : word;
X Hour,Minute,Second,Hundredths : word;
X
Xbegin
X GetTime(Hour, Minute, Second, Hundredths);
X GetDate(Year, Month, Day, Weekday);
X Writeln('The date is ',Month:2,'/',Day:2,'/',Year);
X Writeln('The time is ',Hour:2,':',Minute:2,':',Second:2);
Xend.
________This_Is_The_END________
if test `wc -c < timedat4.pas` -ne 399; then
echo 'shar: timedat4.pas was damaged during transit (should have been 399 bytes)'
fi
fi ; : end of overwriting check
echo 'x - unsq.pas'
if test -f unsq.pas; then echo 'shar: not overwriting unsq.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > unsq.pas
X
X(*
X DEARC.PAS - Program to extract all files from an archive created by version
X 5.12 or earlier of the ARC utility.
X
X *** ORIGINAL AUTHOR UNKNOWN ***
X*)
X
XProgram DearcSQ;
X
X{$R-}
X{$U-}
X{$C-}
X{$K-}
X
Xconst
X BLOCKSIZE = 128;
X arcmarc = 26; { special archive marker }
X arcver = 9; { max archive header version code }
X strlen = 100; { standard string length }
X fnlen = 12; { file name length - 1 }
X
Xconst
X crctab : array [0..255] of integer =
X ( $0000, $C0C1, $C181, $0140, $C301, $03C0, $0280, $C241,
X $C601, $06C0, $0780, $C741, $0500, $C5C1, $C481, $0440,
X $CC01, $0CC0, $0D80, $CD41, $0F00, $CFC1, $CE81, $0E40,
X $0A00, $CAC1, $CB81, $0B40, $C901, $09C0, $0880, $C841,
X $D801, $18C0, $1980, $D941, $1B00, $DBC1, $DA81, $1A40,
X $1E00, $DEC1, $DF81, $1F40, $DD01, $1DC0, $1C80, $DC41,
X $1400, $D4C1, $D581, $1540, $D701, $17C0, $1680, $D641,
X $D201, $12C0, $1380, $D341, $1100, $D1C1, $D081, $1040,
X $F001, $30C0, $3180, $F141, $3300, $F3C1, $F281, $3240,
X $3600, $F6C1, $F781, $3740, $F501, $35C0, $3480, $F441,
X $3C00, $FCC1, $FD81, $3D40, $FF01, $3FC0, $3E80, $FE41,
X $FA01, $3AC0, $3B80, $FB41, $3900, $F9C1, $F881, $3840,
X $2800, $E8C1, $E981, $2940, $EB01, $2BC0, $2A80, $EA41,
X $EE01, $2EC0, $2F80, $EF41, $2D00, $EDC1, $EC81, $2C40,
X $E401, $24C0, $2580, $E541, $2700, $E7C1, $E681, $2640,
X $2200, $E2C1, $E381, $2340, $E101, $21C0, $2080, $E041,
X $A001, $60C0, $6180, $A141, $6300, $A3C1, $A281, $6240,
X $6600, $A6C1, $A781, $6740, $A501, $65C0, $6480, $A441,
X $6C00, $ACC1, $AD81, $6D40, $AF01, $6FC0, $6E80, $AE41,
X $AA01, $6AC0, $6B80, $AB41, $6900, $A9C1, $A881, $6840,
X $7800, $B8C1, $B981, $7940, $BB01, $7BC0, $7A80, $BA41,
X $BE01, $7EC0, $7F80, $BF41, $7D00, $BDC1, $BC81, $7C40,
X $B401, $74C0, $7580, $B541, $7700, $B7C1, $B681, $7640,
X $7200, $B2C1, $B381, $7340, $B101, $71C0, $7080, $B041,
X $5000, $90C1, $9181, $5140, $9301, $53C0, $5280, $9241,
X $9601, $56C0, $5780, $9741, $5500, $95C1, $9481, $5440,
X $9C01, $5CC0, $5D80, $9D41, $5F00, $9FC1, $9E81, $5E40,
X $5A00, $9AC1, $9B81, $5B40, $9901, $59C0, $5880, $9841,
X $8801, $48C0, $4980, $8941, $4B00, $8BC1, $8A81, $4A40,
X $4E00, $8EC1, $8F81, $4F40, $8D01, $4DC0, $4C80, $8C41,
X $4400, $84C1, $8581, $4540, $8701, $47C0, $4680, $8641,
X $8201, $42C0, $4380, $8341, $4100, $81C1, $8081, $4040 );
X
Xtype
X longtype = record { used to simulate long (4 byte) integers }
X l, h : integer
X end;
X
X strtype = string[strlen];
X fntype = array [0..fnlen] of char;
X buftype = array [1..BLOCKSIZE] of byte;
X heads = record
X name : fntype;
X size : longtype;
X date : integer;
X time : integer;
X crc : integer;
X length : longtype
X end;
X
Xvar
X hdrver : byte;
X arcfile : file;
X arcbuf : buftype;
X arcptr : integer;
X arcname : strtype;
X endfile : boolean;
X extfile : file;
X extbuf : buftype;
X extptr : integer;
X extname : strtype;
X
X{ definitions for unpack }
X
XConst
X DLE = $90;
X
XVar
X state : (NOHIST, INREP);
X crcval : integer;
X size : real;
X lastc : integer;
X
X{ definitions for unsqueeze }
X
XConst
X ERROR = -1;
X SPEOF = 256;
X NUMVALS = 256; { 1 less than the number of values }
X
XType
X nd = record
X child : array [0..1] of integer
X end;
X
XVar
X node : array [0..NUMVALS] of nd;
X bpos : integer;
X curin : integer;
X numnodes : integer;
X
X{ definitions for uncrunch }
X
XConst
X TABSIZE = 4096;
X TABSIZEM1 = 4095;
X NO_PRED = $FFFF;
X EMPTY = $FFFF;
X
XType
X entry = record
X used : boolean;
X next : integer;
X predecessor : integer;
X follower : byte
X end;
X
XVar
X stack : array [0..TABSIZEM1] of byte;
X sp : integer;
X string_tab : array [0..TABSIZEM1] of entry;
X
XVar
X code_count : integer;
X code : integer;
X firstc : boolean;
X oldcode : integer;
X finchar : integer;
X inbuf : integer;
X outbuf : integer;
X newhash : boolean;
X
X{ definitions for dynamic uncrunch }
X
XConst
X Crunch_BITS = 12;
X Squash_BITS = 13;
X HSIZE = 8192;
X INIT_BITS = 9;
X FIRST = 257;
X CLEAR = 256;
X HSIZEM1 = 8191;
X BITSM1 = 12;
X
X RMASK : array[0..8] of byte =
X ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);
X
XVar
X bits,
X n_bits,
X maxcode : integer;
X prefix : array[0..HSIZEM1] of integer;
X suffix : array[0..HSIZEM1] of byte;
X buf : array[0..BITSM1] of byte;
X clear_flg : integer;
X stack1 : array[0..HSIZEM1] of byte;
X free_ent : integer;
X maxcodemax : integer;
X offset,
X sizex : integer;
X firstch : boolean;
X
Xprocedure abortme(s : strtype);
X{ terminate the program with an error message }
Xbegin
X writeln('ABORT: ', s);
X halt;
Xend; (* proc abortme *)
X
Xfunction fn_to_str(var fn : fntype) : strtype;
X{ convert strings from C format (trailing 0) to Turbo Pascal format (leading
X length byte). }
Xvar s : strtype;
X i : integer;
Xbegin
X s := '';
X i := 0;
X while fn[i] <> #0 do begin
X s := s + fn[i];
X i := i + 1
X end;
X fn_to_str := s
Xend; (* func fn_to_str *)
X
Xfunction unsigned_to_real(u : integer) : real;
X{ convert unsigned integer to real }
X{ note: INT is a function that returns a REAL!!!}
Xbegin
X if u >= 0 then
X unsigned_to_real := Int(u)
X else
X if u = $8000 then
X unsigned_to_real := 32768.0
X else
X unsigned_to_real := 65536.0 + u
Xend; (* func unsigned_to_real *)
X
Xfunction long_to_real(l : longtype) : real;
X{ convert longtype integer to a real }
X{ note: INT is a function that returns a REAL!!! }
Xvar r : real;
X s : (posit, NEG);
Xconst rcon = 65536.0;
Xbegin
X if l.h >= 0 then begin
X r := Int(l.h) * rcon;
X s := posit {notice: no ";" here}
X end
X else begin
X s := NEG;
X if l.h = $8000 then
X r := rcon * rcon
X else
X r := Int(-l.h) * rcon
X end;
X r := r + unsigned_to_real(l.l);
X if s = NEG then
X long_to_real := -r
X else
X long_to_real := r
Xend; (* func long_to_real *)
X
Xprocedure Read_Block;
X{ read a block from the archive file }
Xbegin
X if EOF(arcfile) then
X endfile := TRUE
X else
X BlockRead(arcfile, arcbuf, 1);
X arcptr := 1
Xend; (* proc read_block *)
X
Xprocedure Write_Block;
X{ write a block to the extracted file }
Xbegin
X BlockWrite(extfile, extbuf, 1);
X extptr := 1
Xend; (* proc write_block *)
X
Xprocedure open_arc;
X{ open the archive file for input processing }
Xbegin
X {$I-} assign(arcfile, arcname); {$I+}
X if ioresult <> 0 then
X abortme('Cannot open archive file.');
X {$I-} reset(arcfile); {$I+}
X if ioresult <> 0 then
X abortme('Cannot open archive file.');
X endfile := FALSE;
X Read_Block
Xend; (* proc open_arc *)
X
Xprocedure open_ext;
X{ open the extracted file for writing }
Xbegin
X {$I-} assign(extfile, extname); {$I+}
X if ioresult <> 0 then
X abortme('Cannot open extract file.');
X {$I-} rewrite(extfile); {$I+}
X if ioresult <> 0 then
X abortme('Cannot open extract file.');
X extptr := 1;
Xend; (* proc open_ext *)
X
Xfunction get_arc : byte;
X{ read 1 character from the archive file }
Xbegin
X if endfile then
X get_arc := 0
X else begin
X get_arc := arcbuf[arcptr];
X if arcptr = BLOCKSIZE then
X Read_Block
X else
X arcptr := arcptr + 1
X end
Xend; (* func get_arc *)
X
Xprocedure put_ext(c : byte);
X{ write 1 character to the extracted file }
Xbegin
X extbuf[extptr] := c;
X if extptr = BLOCKSIZE then
X Write_Block
X else
X extptr := extptr + 1
Xend; (* proc put_ext *)
X
Xprocedure close_arc;
X{ close the archive file }
Xbegin
X close(arcfile)
Xend; (* proc close_arc *)
X
Xprocedure close_ext;
X{ close the extracted file }
Xbegin
X while extptr <> 1 do
X put_ext(Ord(^Z)); { pad last block w/ Ctrl-Z (EOF) }
X close(extfile)
Xend; (* proc close_ext *)
X
Xprocedure fseek(offset : real; base : integer);
X{ re-position the current pointer in the archive file }
Xvar b : real;
X i, ofs, rec : integer;
X c : byte;
Xbegin
X case base of
X 0 : b := offset;
X 1 : b := offset + (unsigned_to_real(FilePos(arcfile)) - 1.0) * BLOCKSIZE
X + arcptr - 1.0;
X 2 : b := offset + unsigned_to_real(FileSize(arcfile)) * BLOCKSIZE - 1.0
X else
X abortme('Invalid parameters to fseek')
X end;
X rec := Trunc(b / BLOCKSIZE);
X ofs := Trunc(b - (Int(rec) * BLOCKSIZE)); { Int converts to Real }
X seek(arcfile, rec);
X Read_Block;
X for i := 1 to ofs do
X c := get_arc
Xend; (* proc fseek *)
X
Xprocedure fread(var buf; reclen : integer);
X{ read a record from the archive file }
Xvar i : integer;
X b : array [1..MaxInt] of byte absolute buf;
Xbegin
X for i := 1 to reclen do
X b[i] := get_arc
Xend; (* proc fread *)
X
Xprocedure GetArcName;
X{ get the name of the archive file }
Xvar i : integer;
Xbegin
X if ParamCount > 1 then
X abortme('Too many parameters');
X if ParamCount = 1 then
X arcname := ParamStr(1)
X else begin
X write('Enter archive filename: ');
X readln(arcname);
X if arcname = '' then
X abortme('No file name entered');
X writeln;
X writeln;
X end;
X for i := 1 to length(arcname) do
X arcname[i] := UpCase(arcname[i]);
X if pos('.', arcname) = 0 then
X arcname := arcname + '.ARC'
Xend; (* proc GetArcName *)
X
Xfunction readhdr(var hdr : heads) : boolean;
X{ read a file header from the archive file }
X{ FALSE = eof found; TRUE = header found }
Xvar name : fntype;
X try : integer;
Xbegin
X try := 10;
X if endfile then begin
X readhdr := FALSE;
X exit;
X end;
X while get_arc <> arcmarc do begin
X if try = 0 then
X abortme(arcname + ' is not an archive');
X try := try - 1;
X writeln(arcname, ' is not an archive, or is out of sync');
X if endfile then
X abortme('Archive length error')
X end; (* while *)
X hdrver := get_arc;
X if hdrver < 0 then
X abortme('Invalid header in archive ' + arcname);
X if hdrver = 0 then begin { special end of file marker }
X readhdr := FALSE;
X exit;
X end;
X if hdrver > arcver then begin
X fread(name, fnlen);
X writeln('I dont know how to handle file ', fn_to_str(name),
X ' in archive ', arcname);
X writeln('I think you need a newer version of DEARC.');
X halt;
X end;
X if hdrver = 1 then begin
X fread(hdr, sizeof(heads) - sizeof(longtype));
X hdrver := 2;
X hdr.length := hdr.size
X end
X else
X fread(hdr, sizeof(heads));
X readhdr := TRUE;
Xend; (* func readhdr *)
X
Xprocedure putc_unp(c : integer);
Xbegin
X crcval := ((crcval shr 8) and $00FF) xor crctab[(crcval xor c) and $00FF];
X put_ext(c)
Xend; (* proc putc_unp *)
X
Xprocedure putc_ncr(c : integer);
Xbegin
X case state of
X NOHIST : if c = DLE then
X state := INREP
X else begin
X lastc := c;
X putc_unp(c)
X end;
X INREP : begin
X if c = 0 then
X putc_unp(DLE)
X else begin
X c := c - 1;
X while (c <> 0) do begin
X putc_unp(lastc);
X c := c - 1
X end
X end;
X state := NOHIST
X end;
X end; (* case *)
Xend; (* proc putc_ncr *)
X
Xfunction getc_unp : integer;
Xbegin
X if size = 0.0 then
X getc_unp := -1
X else begin
X size := size - 1.0;
X getc_unp := get_arc
X end;
Xend; (* func getc_unp *)
X
Xprocedure init_usq;
X{ initialize for unsqueeze }
Xvar i : integer;
Xbegin
X bpos := 99;
X fread(numnodes, sizeof(numnodes));
X if (numnodes < 0) or (numnodes > NUMVALS) then
X abortme('File has an invalid decode tree');
X node[0].child[0] := -(SPEOF + 1);
X node[0].child[1] := -(SPEOF + 1);
X for i := 0 to numnodes-1 do begin
X fread(node[i].child[0], sizeof(integer));
X fread(node[i].child[1], sizeof(integer))
X end;
Xend; (* proc init_usq; *)
X
Xfunction getc_usq : integer;
X{ unsqueeze }
Xvar i : integer;
Xbegin
X i := 0;
X while i >= 0 do begin
X bpos := bpos + 1;
X if bpos > 7 then begin
X curin := getc_unp;
X if curin = ERROR then begin
X getc_usq := ERROR;
X exit;
X end;
X bpos := 0;
X i := node[i].child[1 and curin]
X end
X else begin
X curin := curin shr 1;
X i := node[i].child[1 and curin]
X end
X end; (* while *)
X i := - (i + 1);
X if i = SPEOF then
X getc_usq := -1
X else
X getc_usq := i;
Xend; (* func getc_usq *)
X
Xfunction h(pred, foll : integer) : integer;
X{ calculate hash value }
X{ thanks to Bela Lubkin }
Xvar Local : Real;
X S : String[20];
X I, V : integer;
X C : char;
Xbegin
Xif not newhash then
Xbegin
X Local := (pred + foll) or $0800;
X if Local < 0.0 then
X Local := Local + 65536.0;
X Local := (Local * Local) / 64.0;
X{ convert Local to an integer, truncating high order bits. }
X{ there ***MUST*** be a better way to do this!!! }
X Str(Local:15:5, S);
X V := 0;
X I := 1;
X C := S[1];
X while C <> '.' do begin
X if (C >= '0') and (C <= '9') then
X V := V * 10 + (Ord(C) - Ord('0'));
X I := I + 1;
X C := S[I]
X end;
X h := V and $0FFF
Xend (* func h *)
Xelse
Xbegin
X Local := (pred + foll) * 15073;
X{ convert Local to an integer, truncating high order bits. }
X{ there ***MUST*** be a better way to do this!!! }
X Str(Local:15:5, S);
X V := 0;
X I := 1;
X C := S[1];
X while C <> '.' do begin
X if (C >= '0') and (C <= '9') then
X V := V * 10 + (Ord(C) - Ord('0'));
X I := I + 1;
X C := S[I]
X end;
X h := V and $0FFF
Xend;
Xend;
X
Xfunction eolist(index : integer) : integer;
Xvar temp : integer;
Xbegin
X temp := string_tab[index].next;
X while temp <> 0 do begin
X index := temp;
X temp := string_tab[index].next
X end;
X eolist := index
Xend; (* func eolist *)
X
Xfunction hash(pred, foll : integer) : integer;
Xvar local : integer;
X tempnext : integer;
Xbegin
X local := h(pred, foll);
X if not string_tab[local].used then
X hash := local
X else begin
X local := eolist(local);
X tempnext := (local + 101) and $0FFF;
X while string_tab[tempnext].used do begin
X tempnext := tempnext + 1;
X if tempnext = TABSIZE then
X tempnext := 0
X end;
X string_tab[local].next := tempnext;
X hash := tempnext
X end;
Xend; (* func hash *)
X
Xprocedure upd_tab(pred, foll : integer);
Xbegin
X with string_tab[hash(pred, foll)] do begin
X used := TRUE;
X next := 0;
X predecessor := pred;
X follower := foll
X end
Xend; (* proc upd_tab *)
X
Xfunction gocode : integer;
Xvar localbuf : integer;
X returnval : integer;
Xbegin
X if inbuf = EMPTY then begin
X localbuf := getc_unp;
X if localbuf = -1 then begin
X gocode := -1;
X exit;
X end;
X localbuf := localbuf and $00FF;
X inbuf := getc_unp;
X if inbuf = -1 then begin
X gocode := -1;
X exit;
X end;
X inbuf := inbuf and $00FF;
X returnval := ((localbuf shl 4) and $0FF0) + ((inbuf shr 4) and $000F);
X inbuf := inbuf and $000F
X end
X else begin
X localbuf := getc_unp;
X if localbuf = -1 then begin
X gocode := -1;
X exit;
X end;
X localbuf := localbuf and $00FF;
X returnval := localbuf + ((inbuf shl 8) and $0F00);
X inbuf := EMPTY
X end;
X gocode := returnval;
Xend; (* func gocode *)
X
Xprocedure push(c : integer);
Xbegin
X stack[sp] := c;
X sp := sp + 1;
X if sp >= TABSIZE then
X abortme('Stack overflow')
Xend; (* proc push *)
X
Xfunction pop : integer;
Xbegin
X if sp > 0 then begin
X sp := sp - 1;
X pop := stack[sp]
X end else
X pop := EMPTY
Xend; (* func pop *)
X
Xprocedure init_tab;
Xvar i : integer;
Xbegin
X FillChar(string_tab, sizeof(string_tab), 0);
X for i := 0 to 255 do
X upd_tab(NO_PRED, i);
X inbuf := EMPTY;
X { outbuf := EMPTY }
Xend; (* proc init_tab *)
X
Xprocedure init_ucr(i:integer);
Xbegin
X newhash := i = 1;
X sp := 0;
X init_tab;
X code_count := TABSIZE - 256;
X firstc := TRUE
Xend; (* proc init_ucr *)
X
Xfunction getc_ucr : integer;
Xvar c : integer;
X code : integer;
X newcode : integer;
Xbegin
X if firstc then begin
X firstc := FALSE;
X oldcode := gocode;
X finchar := string_tab[oldcode].follower;
X getc_ucr := finchar;
X exit;
X end;
X if sp = 0 then begin
X newcode := gocode;
X code := newcode;
X if code = -1 then begin
X getc_ucr := -1;
X exit;
X end;
X if not string_tab[code].used then begin
X code := oldcode;
X push(finchar)
X end;
X while string_tab[code].predecessor <> NO_PRED do
X with string_tab[code] do begin
X push(follower);
X code := predecessor
X end;
X finchar := string_tab[code].follower;
X push(finchar);
X if code_count <> 0 then begin
X upd_tab(oldcode, finchar);
X code_count := code_count - 1
X end;
X oldcode := newcode
X end;
X getc_ucr := pop;
Xend; (* func getc_ucr *)
X
Xfunction getcode : integer;
Xlabel
X next;
Xvar
X code, r_off, bitsx : integer;
X bp : byte;
Xbegin
X if firstch then
X begin
X offset := 0;
X sizex := 0;
X firstch := false;
X end;
X bp := 0;
X if (clear_flg > 0) or (offset >= sizex) or (free_ent > maxcode) then
X begin
X if free_ent > maxcode then
X begin
X n_bits := n_bits + 1;
X if n_bits = BITS then
X maxcode := maxcodemax
X else
X maxcode := (1 shl n_bits) - 1;
X end;
X if clear_flg > 0 then
X begin
X n_bits := INIT_BITS;
X maxcode := (1 shl n_bits) - 1;
X clear_flg := 0;
X end;
X for sizex := 0 to n_bits-1 do
X begin
X code := getc_unp;
X if code = -1 then
X goto next
X else
X buf[sizex] := code;
X end;
X sizex := sizex + 1;
Xnext:
X if sizex <= 0 then
X begin
X getcode := -1;
X exit;
X end;
X offset := 0;
X sizex := (sizex shl 3) - (n_bits - 1);
X end;
X r_off := offset;
X bitsx := n_bits;
X
X { get first byte }
X bp := bp + (r_off shr 3);
X r_off := r_off and 7;
X
X { get first parft (low order bits) }
X code := buf[bp] shr r_off;
X bp := bp + 1;
X bitsx := bitsx - (8 - r_off);
X r_off := 8 - r_off;
X
X if bitsx >= 8 then
X begin
X code := code or (buf[bp] shl r_off);
X bp := bp + 1;
X r_off := r_off + 8;
X bitsx := bitsx - 8;
X end;
X
X code := code or ((buf[bp] and rmask[bitsx]) shl r_off);
X offset := offset + n_bits;
X getcode := code;
Xend;
X
Xprocedure decomp( SquashFlag : Integer);
Xlabel
X next;
Xvar
X stackp,
X finchar :integer;
X code, oldcode, incode : integer;
X
Xbegin
X { INIT var }
X if SquashFlag = 0 then
X Bits := crunch_BITS
X else
X Bits := squash_BITS;
X
X if firstch then
X maxcodemax := 1 shl bits;
X
X If SquashFlag = 0 then begin
X code := getc_unp;
X if code <> BITS then
X begin
X Writeln('File packed with ', Code, ' bits, I can only handle ', Bits);
X Halt;
X end;
X end {if};
X clear_flg := 0;
X n_bits := INIT_BITS;
X maxcode := (1 shl n_bits ) - 1;
X for code := 255 downto 0 do
X begin
X prefix[code] := 0;
X suffix[code] := code;
X end;
X
X free_ent := FIRST;
X oldcode := getcode;
X finchar := oldcode;
X if oldcode = -1 then
X exit;
X if SquashFlag = 0 then
X putc_ncr(finchar)
X else
X putc_unp(finchar);
X stackp := 0;
X
X code := getcode;
X while (code > -1) do begin
X if code = CLEAR then
X begin
X for code := 255 downto 0 do
X prefix[code] := 0;
X clear_flg := 1;
X free_ent := FIRST - 1;
X code := getcode;
X if code = -1 then
X goto next;
X end;
Xnext:
X incode := code;
X if code >= free_ent then
X begin
X stack1[stackp] := finchar;
X stackp := stackp + 1;
X code := oldcode;
X end;
X while (code >= 256) do begin
X stack1[stackp] := suffix[code];
X stackp := stackp + 1;
X code := prefix[code];
X end;
X finchar := suffix[code];
X stack1[stackp] := finchar;
X stackp := stackp + 1;
X repeat
X stackp := stackp - 1;
X If SquashFlag = 0 then
X putc_ncr(stack1[stackp])
X else
X putc_unp(stack1[stackp]);
X until stackp <= 0;
X code := free_ent;
X if code < maxcodemax then
X begin
X prefix[code] := oldcode;
X suffix[code] := finchar;
X free_ent := code + 1;
X end;
X oldcode := incode;
X code := getcode;
X end;
Xend;
X
Xprocedure unpack(var hdr : heads);
Xvar c : integer;
Xbegin
X crcval := 0;
X size := long_to_real(hdr.size);
X state := NOHIST;
X FirstCh := TRUE;
X case hdrver of
X 1, 2 : begin
X c := getc_unp;
X while c <> -1 do begin
X putc_unp(c);
X c := getc_unp
X end
X end;
X 3 : begin
X c := getc_unp;
X while c <> -1 do begin
X putc_ncr(c);
X c := getc_unp
X end
X end;
X 4 : begin
X init_usq;
X c := getc_usq;
X while c <> -1 do begin
X putc_ncr(c);
X c := getc_usq
X end
X end;
X 5 : begin
X init_ucr(0);
X c := getc_ucr;
X while c <> -1 do begin
X putc_unp(c);
X c := getc_ucr
X end
X end;
X 6 : begin
X init_ucr(0);
X c := getc_ucr;
X while c <> -1 do begin
X putc_ncr(c);
X c := getc_ucr
X end
X end;
X 7 : begin
X init_ucr(1);
X c := getc_ucr;
X while c <> -1 do begin
X putc_ncr(c);
X c := getc_ucr
X end
X end;
X 8 : begin
X decomp(0);
X end;
X 9 : begin
X decomp(1);
X end;
X else
X writeln('I dont know how to unpack file ', fn_to_str(hdr.name));
X writeln('I think you need a newer version of DEARC');
X fseek(long_to_real(hdr.size), 1);
X exit;
X end; (* case *)
X if crcval <> hdr.crc then
X writeln('WARNING: File ', fn_to_str(hdr.name), ' fails CRC check');
Xend; (* proc unpack *)
X
Xprocedure extract_file(var hdr : heads);
Xbegin
X extname := fn_to_str(hdr.name);
X writeln('Extracting file : ', extname);
X open_ext;
X unpack(hdr);
X close_ext
Xend; (* proc extract *)
X
Xprocedure extarc;
Xvar hdr : heads;
Xbegin
X open_arc;
X while readhdr(hdr) do
X extract_file(hdr);
X close_arc
Xend; (* proc extarc *)
X
Xprocedure PrintHeading;
Xbegin
X writeln;
X writeln('Turbo Pascal DEARC Utility');
X writeln('Version 3.01, 8/8/87');
X writeln('Supports Phil Katz "squashed" files');
X writeln;
Xend; (* proc PrintHeading *)
X
Xbegin
X PrintHeading; { print a heading }
X GetArcName; { get the archive file name }
X extarc; { extract all files from the archive }
Xend.
X
X
X
________This_Is_The_END________
if test `wc -c < unsq.pas` -ne 22554; then
echo 'shar: unsq.pas was damaged during transit (should have been 22554 bytes)'
fi
fi ; : end of overwriting check
echo 'x - varrec.pas'
if test -f varrec.pas; then echo 'shar: not overwriting varrec.pas'; else
sed 's/^X//' << '________This_Is_The_END________' > varrec.pas
X
X(*
X * Examples of variant record types
X *)
X
Xprogram Variant_Record_Example;
X
Xtype
X Kind_Of_Vehicle = (Car,Truck,Bicycle,Boat);
X
X Vehicle = record
X Owner_Name : string[25];
X Gross_Weight : integer;
X Value : real;
X case What_Kind : Kind_Of_Vehicle of
X Car : (Wheels : integer;
X Engine : string[8]);
X Truck : (Motor : string[8];
X Tires : integer;
X Payload : integer);
X Bicycle : (Tyres : integer);
X Boat : (Prop_Blades : byte;
X Sail : boolean;
X Power : string[8]);
X end; (* of record *)
X
Xvar
X Sunfish,Ford,Schwinn,Mac : Vehicle;
X
Xbegin (* main program *)
X Ford.Owner_Name := 'Walter'; (* fields defined in order *)
X Ford.Gross_Weight := 5750;
X Ford.Value := 2595.00;
X Ford.What_Kind := Truck;
X Ford.Motor := 'V8';
X Ford.Tires := 18;
X Ford.Payload := 12000;
X
X with Sunfish do begin
X What_Kind := Boat; (* fields defined in random order *)
X Sail := TRUE;
X Prop_Blades := 3;
X Power := 'wind';
X Gross_Weight := 375;
X Value := 1300.00;
X Owner_Name := 'Herman and George';
X end;
X
X Ford.Engine := 'flathead'; (* tag-field not defined yet but it *)
X Ford.What_Kind := Car; (* must be before it can be used *)
X Ford.Wheels := 4;
X (* notice that the non variant part is not redefined here *)
X
X Mac := Sunfish; (* entire record copied, including the tag-field *)
X
X if Ford.What_Kind = Car then (* this should print *)
X Writeln(Ford.Owner_Name,' owns the car with a ',Ford.Engine,
X ' engine');
X
X if Sunfish.What_Kind = Bicycle then (* this should not print *)
X Writeln('The sunfish is a bicycle which it shouldn''t be');
X
X if Mac.What_Kind = Boat then (* this should print *)
X Writeln('The mac is now a boat with',Mac.Prop_Blades:2,
X ' propeller blades.');
Xend. (* of main program *)
________This_Is_The_END________
if test `wc -c < varrec.pas` -ne 2009; then
echo 'shar: varrec.pas was damaged during transit (should have been 2009 bytes)'
fi
fi ; : end of overwriting check
exit 0
More information about the Comp.sources.misc
mailing list