PACKET digit conversion DEFINES bin,
dec,
hex :
{ Rechnet Dezimalzahlen in Hexadezimalzahlen um und umgekehrt,
sowie Dezimalzahlen in Binärzahlen.
Autor Version Datum
Christian Lehmann 2 07.09.90 }
LET hex letters = "123456789abcdef";
TEXT CONST empty binary digit := 16 * "0",
empty hex digit := "0000";
ROW 4 INT CONST sedecimal powers := ROW 4 INT : (1, 16, 256, 4096);
ROW 16 INT CONST binary powers := ROW 16 INT :
( 1, 2, 4, 8, 16, 32, 64, 128,
256, 512, 1024, 2048, 4096, 8192, 16384, -32767-1);
INT PROC dec (TEXT CONST hex text):
INT VAR stellen := LENGTH hex text;
IF stellen > 4 COR hex text > "7fff"
THEN errorstop ("Zahl zu groß")
FI;
INT VAR dec result := 0, stelle, hex digit;
TEXT VAR hex letter;
FOR stelle FROM 1 UPTO stellen REP
hex letter := hex text SUB (stellen - stelle + 1);
hex digit := pos (hex letters, hex letter);
IF hex digit <> 0
THEN dec result INCR hex digit * sedecimal powers [stelle]
ELIF hex letter <> "0"
THEN errorstop ("Hexadezimalzahl fehlerhaft")
FI
PER;
dec result
END PROC dec;
{ kann nicht durch `replace' zu Beginn verkleinert werden }
TEXT PROC hex (INT CONST decimal int) :
INT VAR nibble no, nibble bit no, bit no := 16, hex digit;
TEXT VAR hex result := empty hex digit;
FOR nibble no FROM 4 DOWNTO 1 REP
hex digit := 0;
FOR nibble bit no FROM 4 DOWNTO 1 REP
IF (decimal int AND binary powers [bit no]) = binary powers [bit no]
THEN hex digit INCR binary powers [nibble bit no]
FI;
bit no DECR 1
PER;
IF hex digit <> 0
THEN replace (hex result, 5 - nibble no, (hex letters SUB hex digit))
FI
PER;
hex result
END PROC hex;
TEXT PROC bin (INT CONST dez) :
TEXT VAR bin result := empty binary digit;
INT VAR bit no;
FOR bit no FROM 16 DOWNTO 1 REP
IF (dez AND binary powers [bit no]) = binary powers [bit no]
THEN replace (bin result, 17 - bit no, "1")
FI
PER;
bin result
END PROC bin;
END PACKET digit conversion;
(* Test *)
(*
INT VAR x, y;
TEXT VAR z;
page;
putline ("Dezimalzahl oder Hexadezimalzahl (mit Kleinbuchstaben und `h' am Schluß)");
putline ("Abbruch durch `0'");
REP
line;
get cursor (x, y);
put ("Zahl:");
get (z);
cursor (x + 14, y);
put (":");
IF (z SUB LENGTH z) = "h"
THEN put (dec (subtext (z, 1, LENGTH z - 1)))
ELSE put (hex (z))
FI
UNTIL z = "0" PER
*)