Category : Modula II Source Code
Archive   : STDLIB.ZIP
Filename : PRINTFBA.MOD

 
Output of file : PRINTFBA.MOD contained in archive : STDLIB.ZIP

IMPLEMENTATION MODULE PrintFBase;

FROM SYSTEM IMPORT
ADR;
FROM Bytes IMPORT
Scan,Move;
FROM Terminal IMPORT
Write,WriteLn,WriteString;
FROM Strings IMPORT
Justify,JustifyTypes;

CONST MaxArgs = 5;
UpperDigits = '0123456789ABCDEF';
LowerDigits = '0123456789abcdef';

TYPE StringPtr = POINTER TO ARRAY[0..0FFFH] OF CHAR;

CardType = (short,card,long);

CardPointer = POINTER TO
RECORD
CASE :CardType OF

short:shortp:SHORTCARD;
| card:cardp:CARDINAL;
| long:longp:LONGCARD;

END;
END;

VAR PatAddr,DestAddr:StringPtr;
NumberBase:LONGCARD;
ArgNo,ArgCount,Patp,Destp,PatMax,DestMax:CARDINAL;
ArgList:ARRAY[0..MaxArgs-1] OF ADDRESS;
Size:ARRAY[0..MaxArgs-1] OF CARDINAL;
Digits:ARRAY[0..15] OF CHAR;
Convert:ARRAY[0..51] OF PROC;

(*....................................*)

PROCEDURE Length(VAR s:ARRAY OF CHAR; Max:CARDINAL):CARDINAL;
BEGIN
RETURN Scan(ADR(s),Max,0C);
END Length;

(*....................................*)

PROCEDURE Error(ErrNo:CARDINAL);

VAR argnumstr:ARRAY[0..9] OF CHAR;

BEGIN
WriteLn;
WriteString('PrintF Error --> ');
CASE ErrNo OF

1:WriteString('Unexpected end of spec. input.');
| 2:WriteString('Argument does not match specification.');
| 3:WriteString('Wrong number of args.');
| 4:WriteString('Not a recognised field specifier');
| 5:WriteString('Not enough room in dest string.');
| 6:WriteString('Char codes must be three digits.');
| 7:WriteString('Width argument must be cardinal.');
| 8:WriteString('NewConversion, Type Char must be in {a..z, A..Z}');

END; (* cases *)
WriteLn;
HALT;
END Error;

(*....................................*)

PROCEDURE CToS(c:LONGCARD; VAR i:CARDINAL);
BEGIN
IF c>=NumberBase THEN CToS(c DIV NumberBase,i) END;
DestString[i] := Digits[CARDINAL(c MOD NumberBase)];
INC(i);
END CToS;

(*....................................*)

PROCEDURE ReadLong(VAR l:LONGCARD);

VAR p:CardPointer;

BEGIN
p := Data;
IF DataSize=1 THEN
l := LONGCARD(p^.shortp)
ELSIF DataSize=2 THEN
l := LONGCARD(p^.cardp)
ELSIF DataSize=4 THEN
l := p^.longp
ELSE
Error(2);
END;
END ReadLong;

(*....................................*)

PROCEDURE CardToString;
(* Handle conversion to string of SHORTCARD,CARDINAL and LONGCARD for all
number bases from 2-16. Note that only bases 8,10 & 16 are supported by
the field spec protocol.
*)

VAR i:CARDINAL;
c:LONGCARD;

BEGIN
IF TypeChar='o' THEN
NumberBase := 8
ELSIF TypeChar='u' THEN
NumberBase := 10
ELSE
NumberBase := 16;
END;
ReadLong(c);
i:=0;
IF AlwaysSigned THEN
DestString[0]:=Positive; INC(i);
END;
CToS(c,i); DestString[i]:=0C;
END CardToString;

(*....................................*)

PROCEDURE LowerCaseHex;
BEGIN
Digits:=LowerDigits;
CardToString;
Digits:=UpperDigits
END LowerCaseHex;

(*....................................*)

PROCEDURE IntToString;
(* Handle conversion to string of SHORTINT,INTEGER and LONGINT *)

VAR i:CARDINAL;
p:CardPointer;
x:LONGINT;

BEGIN
NumberBase := 10;
p := Data;
IF DataSize=1 THEN
x := LONGINT(p^.shortp)
ELSIF DataSize=2 THEN
x := LONGINT(p^.cardp)
ELSIF DataSize=4 THEN
x := p^.longp
ELSE
Error(2);
END;
i:=0;
IF x<0 THEN
DestString[0]:='-'; INC(i); x:=-x
ELSIF AlwaysSigned THEN
DestString[0]:=Positive; INC(i)
END;
CToS(LONGCARD(x),i); DestString[i]:=0C;
END IntToString;

(*....................................*)

PROCEDURE CopyString;

VAR Lnth:CARDINAL;
stringp:StringPtr;

BEGIN
stringp := Data;
Lnth := Length(stringp^,DataSize);
Move(Data,ADR(DestString),Lnth);
DestString[Lnth] := 0C;
END CopyString;

(*....................................*)

PROCEDURE StoreChar(Ch:CHAR);
BEGIN
IF Destp<>DestMax THEN
DestAddr^[Destp] := Ch;
INC(Destp);
END;
END StoreChar;

(*....................................*)

PROCEDURE CopyChar;

VAR charp:POINTER TO CHAR;

BEGIN
IF DataSize=1 THEN
charp := Data;
DestString[0] := charp^;
DestString[1] := 0C
ELSE
Error(2)
END;
END CopyChar;

(*....................................*)

PROCEDURE Parse;

VAR Ch:CHAR;

(*. . . . . . . . . . . . . . . . . . .*)

PROCEDURE GetChar(VAR Ch:CHAR):BOOLEAN;
BEGIN
IF Patp=PatMax THEN
Ch := 0C;
ELSE
Ch := PatAddr^[Patp]; INC(Patp);
END;
RETURN Ch<>0C;
END GetChar;

(*. . . . . . . . . . . . . . . . . . .*)

PROCEDURE NextChar;
BEGIN
IF NOT GetChar(Ch) THEN Error(1) END;
END NextChar;

(*. . . . . . . . . . . . . . . . . . .*)

PROCEDURE ReadNumber(VAR c:CARDINAL);

VAR temp:LONGCARD;

BEGIN
IF Ch='*' THEN
NextChar;
IF ArgNo=ArgCount THEN Error(3) END;
Data:=ArgList[ArgNo]; DataSize:=Size[ArgNo]; INC(ArgNo);
ReadLong(temp);
IF temp>255 THEN Error(7) ELSE c:=CARDINAL(temp) END
ELSE
c := 0;
WHILE (Ch>='0') AND (Ch<='9') DO
c := c*10 + ORD(Ch)-48;
NextChar;
END;
END;
END ReadNumber;

(*. . . . . . . . . . . . . . . . . . .*)

PROCEDURE FieldSpecification;

VAR Lnth,i:CARDINAL;
Just:JustifyTypes;
TestCh:CHAR;

BEGIN
IF ArgNo=ArgCount THEN Error(3) END;
RightJustify:=TRUE; FieldWidth:=0; Places:=5; PadChar:=' ';
AlwaysSigned:=FALSE;
NextChar;
IF Ch='%' THEN StoreChar(Ch); RETURN END;
LOOP
IF Ch='-' THEN
RightJustify:=FALSE; NextChar
ELSIF (Ch='+') OR (Ch=' ') THEN
AlwaysSigned:=TRUE; Positive:=Ch; NextChar
ELSIF Ch='0' THEN
PadChar:='0'; NextChar
ELSIF (Ch>='1') AND (Ch<='9') THEN
ReadNumber(FieldWidth);
IF Ch='.' THEN NextChar; ReadNumber(Places) END
ELSE
EXIT
END;
END;
TestCh := CAP(Ch);
IF (TestCh>='A') AND (TestCh<='Z') THEN
TypeChar := Ch;
IF ArgNo=ArgCount THEN Error(3) END;
Data := ArgList[ArgNo];
DataSize := Size[ArgNo];
IF (TypeChar>='a') AND (TypeChar<='z') THEN
i := ORD(TypeChar)-ORD('a')
ELSE
i := 26 + (ORD(TypeChar)-ORD('A'))
END;
IF Convert[i]=PROC(NIL) THEN
Error(4)
ELSE
Convert[i]();
END
ELSE
Error(4)
END;
IF RightJustify THEN Just:=Right ELSE Just:=Left END;
Lnth := Justify(Just,DestString,FieldWidth,PadChar);
IF Destp+Lnth>DestMax THEN Lnth:=DestMax-Destp END;
Move(ADR(DestString),ADR(DestAddr^[Destp]),Lnth);
INC(Destp,Lnth);
INC(ArgNo);
END FieldSpecification;

(*. . . . . . . . . . . . . . . . . . .*)

PROCEDURE SwitchChar;

VAR code,i:CARDINAL;
c:CHAR;

BEGIN
NextChar;
CASE CAP(Ch) OF

'B':c:=CHR(8);
| 'F':c:=CHR(12);
| 'N':StoreChar(CHR(13));
c:=CHR(10);
| 'R':c:=CHR(13);
| 'T':c:=CHR(9);
| '0'..'9':code:=ORD(Ch)-48;
FOR i:=0 TO 1 DO
NextChar;
IF (Ch<'0') OR (Ch>'9') THEN Error(6) END;
code:=code*10+ORD(Ch)-48;
END;
c := CHR(code)
ELSE
c := Ch
END; (* cases *)
StoreChar(c);
END SwitchChar;

(*. . . . . . . . . . . . . . . . . . .*)

BEGIN
ArgNo:=0;
WHILE GetChar(Ch) DO
IF Ch='%' THEN
FieldSpecification
ELSIF Ch='\' THEN
SwitchChar
ELSE
StoreChar(Ch);
END;
END;
StoreChar(0C);
END Parse;

(*...............................................*)

PROCEDURE DoPrintF(VAR pat:ARRAY OF CHAR;
VAR arg1,arg2,arg3,arg4,arg5:ARRAY OF BYTE;
VAR dest:ARRAY OF CHAR;
NumArgs:CARDINAL);
BEGIN
ArgCount := NumArgs;
PatAddr:=ADR(pat); Patp:=0; PatMax:=HIGH(pat)+1;
DestAddr:=ADR(dest); Destp:=0; DestMax:=HIGH(dest)+1;
ArgList[0]:=ADR(arg1); Size[0]:=HIGH(arg1)+1;
ArgList[1]:=ADR(arg2); Size[1]:=HIGH(arg2)+1;
ArgList[2]:=ADR(arg3); Size[2]:=HIGH(arg3)+1;
ArgList[3]:=ADR(arg4); Size[3]:=HIGH(arg4)+1;
ArgList[4]:=ADR(arg5); Size[4]:=HIGH(arg5)+1;
Digits := UpperDigits;
Parse;
END DoPrintF;

(*...............................................*)

PROCEDURE NewConversion(TypeChar:CHAR; ConvertRoutine:PROC);

VAR i:CARDINAL;

BEGIN
IF (CAP(TypeChar)>='A') AND (CAP(TypeChar)<='Z') THEN
IF (TypeChar>='a') AND (TypeChar<='z') THEN
i := ORD(TypeChar)-ORD('a')
ELSE
i := 26 + (ORD(TypeChar)-ORD('A'))
END;
Convert[i] := ConvertRoutine
ELSE
Error(8);
END;
END NewConversion;

(*..................................................*)

PROCEDURE InitPrintF;

VAR i:CARDINAL;

BEGIN
FOR i:=0 TO 51 DO Convert[i]:=PROC(NIL) END;
NewConversion('i',IntToString);
NewConversion('u',CardToString);
NewConversion('H',CardToString);
NewConversion('h',LowerCaseHex);
NewConversion('X',CardToString);
NewConversion('x',LowerCaseHex);
NewConversion('o',CardToString);
NewConversion('c',CopyChar);
NewConversion('s',CopyString);
END InitPrintF;

(*..................................................*)

BEGIN
InitPrintF;
END PrintFBase.



  3 Responses to “Category : Modula II Source Code
Archive   : STDLIB.ZIP
Filename : PRINTFBA.MOD

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/