mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
.mod file extension for AMPL, Linux Kernel Module, Modula-2 and XML
This commit is contained in:
Paul Chaignon
329
samples/Modula-2/HuffChan.mod
Normal file
329
samples/Modula-2/HuffChan.mod
Normal file
@@ -0,0 +1,329 @@
|
||||
IMPLEMENTATION MODULE HuffChan;
|
||||
|
||||
(*
|
||||
This module shows how to redefine standard IO file functions. It provides
|
||||
functions for reading and writing packed files opened in Raw mode.
|
||||
*)
|
||||
|
||||
IMPORT IOChan, IOLink, ChanConsts, IOConsts, SYSTEM, Strings;
|
||||
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
|
||||
|
||||
CONST
|
||||
rbldFrq = 512; (* means: every 512 bytes rebuild table *)
|
||||
|
||||
TYPE
|
||||
charTap = POINTER TO ARRAY [0..MAX(INTEGER)-1] OF CHAR;
|
||||
smbTp = POINTER TO smbT;
|
||||
|
||||
smbT = RECORD (* Huffman's tree *)
|
||||
ch : CHAR;
|
||||
n : CARDINAL; (* frequncy of char ch *)
|
||||
left,right,next : smbTp;
|
||||
END;
|
||||
|
||||
tblT = RECORD (* bit sequence for code *)
|
||||
vl : CARDINAL; (* bit sequence *)
|
||||
cnt : INTEGER; (* it length *)
|
||||
END;
|
||||
|
||||
lclDataT = RECORD (* channel's local data *)
|
||||
tRoot : smbTp;
|
||||
htbl : ARRAY [0..255] OF tblT; (* code -> bit sequence table *)
|
||||
ftbl : ARRAY [0..255] OF CARDINAL; (* frequncey table *)
|
||||
wBf,rb1,rb2 : CARDINAL;
|
||||
wbc,rbc,smc : INTEGER;
|
||||
chid : IOChan.ChanId;
|
||||
END;
|
||||
lclDataTp = POINTER TO lclDataT;
|
||||
charp = POINTER TO CHAR;
|
||||
|
||||
VAR
|
||||
did : IOLink.DeviceId;
|
||||
ldt : lclDataTp;
|
||||
|
||||
|
||||
PROCEDURE Shf(a:CARDINAL; b : INTEGER) : CARDINAL; (* shl a,b (or shr) *)
|
||||
BEGIN
|
||||
RETURN SYSTEM.CAST(CARDINAL,SYSTEM.SHIFT(SYSTEM.CAST(BITSET,a),b));
|
||||
END Shf;
|
||||
|
||||
PROCEDURE wrDword(a:CARDINAL); (* write 4 bytes to file *)
|
||||
BEGIN
|
||||
IOChan.RawWrite(ldt^.chid,SYSTEM.ADR(a),4);
|
||||
END wrDword;
|
||||
|
||||
PROCEDURE rdDword() : CARDINAL; (* read 4 bytes from file *)
|
||||
VAR
|
||||
a,z : CARDINAL;
|
||||
BEGIN
|
||||
a:=0;
|
||||
IOChan.RawRead(ldt^.chid,SYSTEM.ADR(a),4,z);
|
||||
RETURN a;
|
||||
END rdDword;
|
||||
|
||||
PROCEDURE wrSmb(ch : CHAR); (* write bit sequence for code ch *)
|
||||
VAR
|
||||
v,h : CARDINAL;
|
||||
b,c : INTEGER;
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
v:=htbl[ORD(ch)].vl;
|
||||
c:=htbl[ORD(ch)].cnt;
|
||||
IF c+wbc<=32 THEN
|
||||
wBf:=Shf(wBf,c);
|
||||
wBf:=wBf+v;
|
||||
wbc:=wbc+c;
|
||||
IF wbc=32 THEN
|
||||
wrDword(wBf);
|
||||
wBf:=0; wbc:=0;
|
||||
END;
|
||||
RETURN;
|
||||
END;
|
||||
b:=c+wbc-32;
|
||||
h:=Shf(v,-b);
|
||||
wBf:=Shf(wBf,32-wbc)+h;
|
||||
wrDword(wBf);
|
||||
wBf:=v-Shf(h,b);
|
||||
wbc:=b;
|
||||
END;
|
||||
END wrSmb;
|
||||
|
||||
PROCEDURE flush(); (* write data in buffer *)
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
wBf:=Shf(wBf,32-wbc);
|
||||
wrDword(wBf);
|
||||
END;
|
||||
END flush;
|
||||
|
||||
PROCEDURE getSym() : CHAR; (* find code for first bit sequence in buffer *)
|
||||
VAR
|
||||
t,i : CARDINAL;
|
||||
b : INTEGER;
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
IF rbc<=32 THEN
|
||||
rb2:=rdDword();
|
||||
t:=Shf(rb2,-rbc);
|
||||
IF rbc=32 THEN t:=0; END;
|
||||
rb1:=rb1+t;
|
||||
rb2:=Shf(rb2,32-rbc);
|
||||
IF rbc=0 THEN rb2:=0; END;
|
||||
rbc:=rbc+32;
|
||||
END;
|
||||
FOR i:=0 TO 255 DO
|
||||
t:=Shf(rb1,htbl[i].cnt-32);
|
||||
IF t=htbl[i].vl THEN
|
||||
rb1:=Shf(rb1,htbl[i].cnt);
|
||||
b:=32-htbl[i].cnt;
|
||||
t:=Shf(rb2,-b);
|
||||
rb1:=rb1+t;
|
||||
rb2:=Shf(rb2,32-b);
|
||||
rbc:=rbc+b-32;
|
||||
RETURN CHR(i);
|
||||
END;
|
||||
END;
|
||||
END;
|
||||
END getSym;
|
||||
|
||||
PROCEDURE Insert(s : smbTp); (* insert new character in Huffman's tree *)
|
||||
VAR
|
||||
cr : smbTp;
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
IF tRoot=NIL THEN
|
||||
cr:=tRoot;
|
||||
tRoot:=s;
|
||||
s^.next:=cr;
|
||||
RETURN;
|
||||
ELSIF tRoot^.n<=s^.n THEN
|
||||
cr:=tRoot;
|
||||
tRoot:=s;
|
||||
s^.next:=cr;
|
||||
RETURN;
|
||||
END;
|
||||
cr:=tRoot;
|
||||
WHILE (cr^.next<>NIL) & (cr^.next^.n>s^.n) DO
|
||||
cr:=cr^.next;
|
||||
END;
|
||||
s^.next:=cr^.next;
|
||||
cr^.next:=s;
|
||||
END;
|
||||
END Insert;
|
||||
|
||||
PROCEDURE BuildTree(); (* build Huffman's tree *)
|
||||
VAR
|
||||
cr,ocr,ncr : smbTp;
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
LOOP
|
||||
ocr:=NIL; cr:=tRoot;
|
||||
WHILE cr^.next^.next<>NIL DO
|
||||
ocr:=cr; cr:=cr^.next;
|
||||
END;
|
||||
NEW(ncr);
|
||||
ncr^.n:=cr^.n+cr^.next^.n;
|
||||
ncr^.left:=cr;
|
||||
ncr^.right:=cr^.next;
|
||||
IF ocr<>NIL THEN
|
||||
ocr^.next:=NIL;
|
||||
Insert(ncr);
|
||||
ELSE
|
||||
tRoot:=NIL;
|
||||
Insert(ncr);
|
||||
EXIT;
|
||||
END;
|
||||
END;
|
||||
END;
|
||||
END BuildTree;
|
||||
|
||||
PROCEDURE BuildTable(cr: smbTp; vl,n: CARDINAL); (* build table: code -> bit sequence *)
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
IF cr^.left=NIL THEN
|
||||
htbl[ORD(cr^.ch)].vl:=vl;
|
||||
htbl[ORD(cr^.ch)].cnt:=n;
|
||||
DISPOSE(cr);
|
||||
RETURN;
|
||||
END;
|
||||
vl:=vl*2;
|
||||
BuildTable(cr^.left,vl,n+1);
|
||||
BuildTable(cr^.right,vl+1,n+1);
|
||||
DISPOSE(cr);
|
||||
END;
|
||||
END BuildTable;
|
||||
|
||||
PROCEDURE clcTab(); (* build code/bitseq. table from frequency table *)
|
||||
VAR
|
||||
i : CARDINAL;
|
||||
s : smbTp;
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
tRoot:=NIL;
|
||||
FOR i:=0 TO 255 DO
|
||||
NEW(s);
|
||||
s^.ch:=CHR(i);
|
||||
s^.n:=ftbl[i];
|
||||
s^.left:=NIL; s^.right:=NIL; s^.next:=NIL;
|
||||
Insert(s);
|
||||
END;
|
||||
BuildTree();
|
||||
BuildTable(tRoot,0,0);
|
||||
END;
|
||||
END clcTab;
|
||||
|
||||
PROCEDURE iniHuf();
|
||||
VAR
|
||||
i : CARDINAL;
|
||||
BEGIN
|
||||
WITH ldt^ DO
|
||||
FOR i:=0 TO 255 DO
|
||||
ftbl[i]:=1;
|
||||
END;
|
||||
wBf:=0; wbc:=0; rb1:=0; rb2:=0; rbc:=0;
|
||||
smc:=0;
|
||||
clcTab();
|
||||
END;
|
||||
END iniHuf;
|
||||
|
||||
|
||||
PROCEDURE RawWrite(x: IOLink.DeviceTablePtr; buf: SYSTEM.ADDRESS;
|
||||
len: CARDINAL);
|
||||
VAR
|
||||
i : CARDINAL;
|
||||
ch : CHAR;
|
||||
cht : charTap;
|
||||
BEGIN
|
||||
IF len = 0 THEN RETURN; END;
|
||||
ldt:=SYSTEM.CAST(lclDataTp,x^.cd);
|
||||
cht:=SYSTEM.CAST(charTap,buf);
|
||||
WITH ldt^ DO
|
||||
FOR i:=0 TO len-1 DO
|
||||
ch:=cht^[i];
|
||||
wrSmb(ch);
|
||||
IF ch = 377C THEN wrSmb(ch); END;
|
||||
ftbl[ORD(ch)]:=ftbl[ORD(ch)]+1; smc:=smc+1;
|
||||
IF smc=rbldFrq THEN
|
||||
clcTab();
|
||||
smc:=0;
|
||||
END;
|
||||
END;
|
||||
END;
|
||||
x^.result:=IOChan.ReadResult(ldt^.chid);
|
||||
END RawWrite;
|
||||
|
||||
PROCEDURE RawRead(x: IOLink.DeviceTablePtr; buf: SYSTEM.ADDRESS;
|
||||
blen: CARDINAL; VAR len: CARDINAL);
|
||||
VAR
|
||||
i : CARDINAL;
|
||||
cht : charTap;
|
||||
ch : CHAR;
|
||||
BEGIN
|
||||
ldt:=SYSTEM.CAST(lclDataTp,x^.cd);
|
||||
cht:=SYSTEM.CAST(charTap,buf);
|
||||
IF (blen=0) OR (x^.result<>IOConsts.allRight) THEN len:=0; RETURN; END;
|
||||
WITH ldt^ DO
|
||||
FOR i:=0 TO blen-1 DO
|
||||
ch:=getSym();
|
||||
IF ch = 377C THEN
|
||||
ch:=getSym();
|
||||
IF ch = 0C THEN
|
||||
x^.result:=IOConsts.endOfInput;
|
||||
len:=i; cht^[i]:=0C;
|
||||
RETURN;
|
||||
END;
|
||||
END;
|
||||
cht^[i]:=ch;
|
||||
ftbl[ORD(ch)]:=ftbl[ORD(ch)]+1; smc:=smc+1;
|
||||
IF smc=rbldFrq THEN
|
||||
clcTab();
|
||||
smc:=0;
|
||||
END;
|
||||
END;
|
||||
len:=blen;
|
||||
END;
|
||||
END RawRead;
|
||||
|
||||
PROCEDURE CreateAlias(VAR cid: ChanId; io: ChanId; VAR res: OpenResults);
|
||||
VAR
|
||||
x : IOLink.DeviceTablePtr;
|
||||
BEGIN
|
||||
IOLink.MakeChan(did,cid);
|
||||
IF cid = IOChan.InvalidChan() THEN
|
||||
res:=ChanConsts.outOfChans
|
||||
ELSE
|
||||
NEW(ldt);
|
||||
IF ldt=NIL THEN
|
||||
IOLink.UnMakeChan(did,cid);
|
||||
res:=ChanConsts.outOfChans;
|
||||
RETURN;
|
||||
END;
|
||||
x:=IOLink.DeviceTablePtrValue(cid,did,IOChan.notAvailable,"");
|
||||
ldt^.chid:=io;
|
||||
x^.cd:=ldt;
|
||||
x^.doRawWrite:=RawWrite;
|
||||
x^.doRawRead:=RawRead;
|
||||
res:=ChanConsts.opened;
|
||||
iniHuf();
|
||||
x^.result:=IOConsts.allRight;
|
||||
END;
|
||||
END CreateAlias;
|
||||
|
||||
PROCEDURE DeleteAlias(VAR cid: ChanId);
|
||||
VAR
|
||||
x : IOLink.DeviceTablePtr;
|
||||
BEGIN
|
||||
x:=IOLink.DeviceTablePtrValue(cid,did,IOChan.notAvailable,"");
|
||||
ldt:=x^.cd;
|
||||
IF ldt^.rbc=0 THEN
|
||||
wrSmb(377C);
|
||||
wrSmb(0C);
|
||||
flush();
|
||||
END;
|
||||
DISPOSE(ldt);
|
||||
IOLink.UnMakeChan(did,cid);
|
||||
END DeleteAlias;
|
||||
|
||||
BEGIN
|
||||
IOLink.AllocateDeviceId(did);
|
||||
END HuffChan.
|
||||
Reference in New Issue
Block a user