Revision 2014-04-25
CRC (Cyclic Rendundancy Check) is used to verify the integrity of transmitted data.
Forth implementations for several popular CRC algorithms are
presented in high-level,
8086 machine-code, bit-shift and table-driven models.
Users may find the output of these CRC routines differ from
those published elsewhere in
Forth literature. The implementations supplied here have been
verified against the 'check'
values specified in the RevEng CRC catalog.
This code requires a 16-bit compiler.
Reference
http://reveng.sourceforge.net/crc-catalogue/
Implementation
\ CRC.F version 1.0
\
\ CRC (Cyclic-Redundancy-Check) generators
\
\ Supported algorithms:
\
\ CRC-16, CRC16-CCITT, CRC16-X25, CRC16-XMODEM,
\ CRC16-KERMIT, CRC32-CCITT
\
\ Implementation dependencies:
\ 16 bit cell size
\ 2's complement arithmetic
\ 1 char = 1 address unit
\
\ Reference:
\ http://reveng.sourceforge.net/crc-catalogue/
\
\ This code is PUBLIC DOMAIN. Use at your own risk.
\
\ History:
\
\ v1.0 2014-04-25 es First release
FORTH DEFINITIONS DECIMAL
\ ************** Compile-time options **************
0 VALUE m/c \ 0 = high-level, 1 = 8086 machine-code
0 VALUE table \ 0 = bit-shift, 1 = table-driven
\ ****************************************************
1 CELLS 2 - [IF]
CR .( Requires a 16-bit Forth, aborting... ) ABORT
[THEN]
table 0= [IF] ( bit-shift)
\ CRC-16 x16+x15+x2+1 Initial CRC = 0
m/c 0= [IF]
: CRC-16 ( crc byt -- crc' )
XOR 8 0 DO DUP 1 AND IF U2/ $A001 XOR ELSE U2/ THEN LOOP ;
[ELSE]
CODE CRC-16 ( crc byt -- crc' )
DX POP AX POP DX AX XOR 8 # CX MOV 1 $: AX 1 SHR
2 $ JNC $A001 # AX XOR 2 $: 1 $ LOOP 1PUSH END-CODE
[THEN]
\ CRC-CCITT x16+x12+x5+1 Initial CRC = -1. Note: This
\ implementation requires 16 0-bits *precede* the data.
m/c 0= [if]
: CRC-CCITT ( crc byt -- crc' )
>< XOR 8 0 DO DUP 0< IF 2* $1021 XOR ELSE 2* THEN LOOP ;
[ELSE]
CODE CRC-CCITT ( crc byt -- crc' )
DX POP AX POP DL DH XCHG DX AX XOR 8 # CX MOV 1 $:
AX 1 SHL 2 $ JNC $1021 # AX XOR 2 $: 1 $ LOOP 1PUSH
END-CODE
[THEN]
\ CRC-X25 x16+x12+x5+1 Initial CRC = -1, INVERT final CRC
m/c 0= [IF]
: CRC-X25 ( crc byt -- crc' )
XOR 8 0 DO DUP 1 AND IF U2/ $8408 XOR ELSE U2/ THEN LOOP ;
[ELSE]
CODE CRC-X25 ( crc byt -- crc' )
DX POP AX POP DX AX XOR 8 # CX MOV 1 $: AX 1 SHR
2 $ JNC $8408 # AX XOR 2 $: 1 $ LOOP 1PUSH END-CODE
[THEN]
\ CRC-32 Initial CRC = -1, DINVERT final CRC
m/c 0= [IF]
: CRC-32 ( dcrc byt -- dcrc' )
8 0 DO -ROT OVER 3 PICK XOR 1 AND >R D2/ $7FFF AND R> IF
$EDB8 XOR SWAP $8320 XOR SWAP THEN ROT 1 RSHIFT LOOP DROP ;
[ELSE]
CODE CRC-32 ( dcrc byt -- dcrc' )
BX POP AX POP DX POP 8 # CX MOV 1 $: BL BH MOV DL BH
XOR AX 1 SHR DX 1 RCR BH 1 SHR 2 $ JNC $EDB8 # AX XOR
$8320 # DX XOR 2 $: BL 1 SHR 1 $ LOOP 2PUSH END-CODE
[THEN]
: DINVERT ( d1 -- d2 ) INVERT SWAP INVERT SWAP ;
[ELSE] ( table)
\ CRC-16 x16+x15+x2+1 Initial CRC = 0
CREATE tb #256 2* ALLOT
: !tb #256 0 DO I 8 0 DO DUP 1 AND >R U2/ R> IF $A001
XOR THEN LOOP I 2* tb + ! LOOP ; !tb FORGET !tb
m/c 0= [IF]
: CRC-16 ( crc 8b -- crc' )
OVER XOR $FF AND 2* tb + @ SWAP 8 RSHIFT XOR ;
[ELSE]
CODE CRC-16 ( crc 8b -- crc' )
BX POP DX POP DL BL XOR BX BX ADD tb # BX ADD
0 [BX] AX MOV DL DH XCHG DH DH SUB DX AX XOR 1PUSH
END-CODE
[THEN]
[DEFINED] DXFORTH [IF] BEHEAD tb tb [THEN]
\ CRC-CCITT x16+x12+x5+1 Initial CRC = -1. Note: This
\ implementation requires 16 0-bits *precede* the data.
CREATE tb #256 2* ALLOT
: !tb #256 0 DO 0 I >< XOR 8 0 DO DUP 0< IF 2* $1021 XOR
ELSE 2* THEN LOOP I 2* tb + ! LOOP ; !tb FORGET !tb
m/c 0= [if]
: CRC-CCITT ( crc 8b -- crc' )
OVER 8 RSHIFT XOR 2* tb + @ SWAP 8 LSHIFT XOR ;
[ELSE]
CODE CRC-CCITT ( crc 8b -- crc' )
BX POP DX POP DH BL XOR BX BX ADD tb # BX ADD
0 [BX] AX MOV DL AH XOR 1PUSH END-CODE
[THEN]
[DEFINED] DXFORTH [IF] BEHEAD tb tb [THEN]
\ CRC-X25 x16+x12+x5+1 Initial CRC = -1, INVERT final CRC
CREATE tb #256 2* ALLOT
: !tb #256 0 DO I 8 0 DO DUP 1 AND >R U2/ R> IF $8408 XOR
THEN LOOP I 2* tb + ! LOOP ; !tb FORGET !tb
m/c 0= [IF]
: CRC-X25 ( crc 8b -- crc' )
OVER XOR $FF AND 2* tb + @ SWAP 8 RSHIFT XOR ;
[ELSE]
CODE CRC-X25 ( crc 8b -- crc' )
BX POP DX POP DL BL XOR BX BX ADD tb # BX ADD
0 [BX] AX MOV DL DH XCHG DH DH SUB DX AX XOR 1PUSH
END-CODE
[THEN]
[DEFINED] DXFORTH [IF] BEHEAD tb tb [THEN]
\ CRC-32 Initial CRC = -1, DINVERT final CRC
CREATE tb #256 2* 2* ALLOT
: !tb #256 0 DO I 0 8 0 DO OVER 1 AND >R D2/ $7FFF AND
R> IF $EDB8 XOR SWAP $8320 XOR SWAP THEN LOOP I 2* 2*
tb + 2! LOOP ; !tb FORGET !tb
m/c 0= [IF]
: CRC-32 ( dcrc 8b -- dcrc' )
2 PICK XOR $FF AND 2* 2* tb + 2@ 2>R 8 0 DO
D2/ LOOP $FF AND R> XOR SWAP R> XOR SWAP ;
[ELSE]
CODE CRC-32 ( dcrc 8b -- dcrc' ) BX POP AX POP
DX POP DL BL XOR BX BX ADD BX BX ADD tb # BX ADD
DH DL MOV AL DH MOV AH AL MOV AH AH SUB 0 [BX] AX XOR
2 [BX] DX XOR 2PUSH END-CODE
[THEN]
[DEFINED] DXFORTH [IF] BEHEAD tb tb [THEN]
: DINVERT ( d1 -- d2 ) INVERT SWAP INVERT SWAP ;
[THEN]
\ Testing
\ The de-facto standard data for testing CRC generators is
\ the string "123456789" (without quotes). The resulting
\ CRC is referred to as the "check" value.
: data ( addr len ) s" 123456789" ;
: (dh.) ( ud -- addr len )
BASE @ >R HEX <# # # # # # # # # #> R> BASE ! ;
: (h.) ( u -- addr len ) 0 (dh.) 4 /STRING ;
DEFER crc ( crc 8b -- crc' )
: GENCRC ( crc adr len -- crc' )
OVER + SWAP ?DO I C@ crc LOOP ;
: test ( -- )
CR ." Testing CRC generators ..." CR
[ m/c ] LITERAL IF ." Machine-code" ELSE ." High-level"
THEN ." , "
[ table ] LITERAL IF ." table-driven." ELSE ." bit-shift."
THEN ." Data: " [CHAR] " DUP EMIT data TYPE EMIT
CR 12 SPACES ." check output"
CR ." CRC-16 [BB3D] "
['] CRC-16 IS crc
0 data gencrc (h.) TYPE
CR ." CRC-CCITT [E5CC] "
['] CRC-CCITT IS crc
-1 0 crc 0 crc data gencrc (h.) TYPE
CR ." CRC-X25 [906E] "
['] CRC-X25 IS crc
-1 data gencrc INVERT (h.) TYPE
CR ." CRC-XMODEM [31C3] "
['] CRC-CCITT IS crc
0 data gencrc (h.) TYPE
CR ." CRC-KERMIT [2189] "
['] CRC-X25 IS crc
0 data gencrc (h.) TYPE
CR ." CRC-32 [CBF43926] "
['] CRC-32 IS crc
-1. data gencrc DINVERT (dh.) TYPE
;
\ end
test
Testing CRC generators ...
High-level, bit-shift. Data: "123456789"
check output
CRC-16 [BB3D] BB3D
CRC-CCITT [E5CC] E5CC
CRC-X25 [906E] 906E
CRC-XMODEM [31C3] 31C3
CRC-KERMIT [2189] 2189
CRC-32 [CBF43926] CBF43926
Top Home Forth
Page updated: 25 Apr 2014