alan@leadsv.UUCP (Alan Strassberg) (08/15/88)
Posting-number: Volume 4, Issue 27 Submitted-by: "Alan Strassberg" <alan@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