net2o: Hex Artifact Content

Artifact cfe04bb3c0b953f86a90329b7f39cb2cfa135f69:

File base85.fs — part of check-in [e68be82525] at 2019-01-25 21:18:14 on branch trunk — Fixes for Gforth ITC, which doesn't like smart compile, compilation semantics, and needs compsem: stuff instead (user: bernd size: 1661)
0000: 5c 20 62 61 73 65 38 35 20 6f 75 74 70 75 74 20  \ base85 output 
0010: 28 64 65 72 69 76 65 64 20 66 72 6f 6d 20 52 46  (derived from RF
0020: 43 20 31 39 32 34 2c 20 73 75 69 74 61 62 6c 65  C 1924, suitable
0030: 20 61 73 20 66 69 6c 65 20 6e 61 6d 65 29 0a 0a   as file name)..
0040: 38 35 20 62 75 66 66 65 72 3a 20 38 35 3e 63 68  85 buffer: 85>ch
0050: 61 72 73 0a 73 22 20 30 31 32 33 34 35 36 37 38  ars.s" 012345678
0060: 39 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f  9ABCDEFGHIJKLMNO
0070: 50 51 52 53 54 55 56 57 58 59 5a 61 62 63 64 65  PQRSTUVWXYZabcde
0080: 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75  fghijklmnopqrstu
0090: 76 77 78 79 7a 21 23 24 25 26 28 29 2a 2b 2d 3b  vwxyz!#$%&()*+-;
00a0: 3c 3d 3e 3f 40 5e 5f 60 7b 7c 7d 7e 22 0a 38 35  <=>?@^_`{|}~".85
00b0: 3e 63 68 61 72 73 20 38 35 20 73 6d 6f 76 65 0a  >chars 85 smove.
00c0: 24 38 30 20 62 75 66 66 65 72 3a 20 63 68 61 72  $80 buffer: char
00d0: 73 3e 38 35 0a 63 68 61 72 73 3e 38 35 20 24 38  s>85.chars>85 $8
00e0: 30 20 24 46 46 20 66 69 6c 6c 0a 38 35 20 30 20  0 $FF fill.85 0 
00f0: 5b 44 4f 5d 20 5b 49 5d 20 64 75 70 20 38 35 3e  [DO] [I] dup 85>
0100: 63 68 61 72 73 20 2b 20 63 40 20 63 68 61 72 73  chars + c@ chars
0110: 3e 38 35 20 2b 20 63 21 20 5b 4c 4f 4f 50 5d 0a  >85 + c! [LOOP].
0120: 0a 3a 20 2e 62 38 35 20 28 20 6e 20 2d 2d 20 6e  .: .b85 ( n -- n
0130: 27 20 29 20 30 20 38 35 20 75 6d 2f 6d 6f 64 20  ' ) 0 85 um/mod 
0140: 73 77 61 70 20 38 35 3e 63 68 61 72 73 20 2b 20  swap 85>chars + 
0150: 63 40 20 65 6d 69 74 20 3b 0a 3a 20 2e 31 62 61  c@ emit ;.: .1ba
0160: 73 65 38 35 20 28 20 61 64 64 72 20 2d 2d 20 29  se85 ( addr -- )
0170: 20 63 40 20 2e 62 38 35 20 2e 62 38 35 20 64 72   c@ .b85 .b85 dr
0180: 6f 70 20 3b 0a 3a 20 2e 32 62 61 73 65 38 35 20  op ;.: .2base85 
0190: 28 20 61 64 64 72 20 2d 2d 20 29 20 6c 65 2d 75  ( addr -- ) le-u
01a0: 77 40 20 2e 62 38 35 20 2e 62 38 35 20 2e 62 38  w@ .b85 .b85 .b8
01b0: 35 20 64 72 6f 70 20 3b 0a 3a 20 2e 33 62 61 73  5 drop ;.: .3bas
01c0: 65 38 35 20 28 20 61 64 64 72 20 2d 2d 20 29 20  e85 ( addr -- ) 
01d0: 6c 65 2d 75 6c 40 20 24 46 46 46 46 46 46 20 61  le-ul@ $FFFFFF a
01e0: 6e 64 20 2e 62 38 35 20 2e 62 38 35 20 2e 62 38  nd .b85 .b85 .b8
01f0: 35 20 2e 62 38 35 20 64 72 6f 70 20 3b 0a 3a 20  5 .b85 drop ;.: 
0200: 2e 34 62 61 73 65 38 35 20 28 20 61 64 64 72 20  .4base85 ( addr 
0210: 2d 2d 20 29 20 6c 65 2d 75 6c 40 20 2e 62 38 35  -- ) le-ul@ .b85
0220: 20 2e 62 38 35 20 2e 62 38 35 20 2e 62 38 35 20   .b85 .b85 .b85 
0230: 2e 62 38 35 20 64 72 6f 70 20 3b 0a 43 72 65 61  .b85 drop ;.Crea
0240: 74 65 20 2e 62 61 73 65 38 35 73 20 27 20 64 72  te .base85s ' dr
0250: 6f 70 20 2c 20 27 20 2e 31 62 61 73 65 38 35 20  op , ' .1base85 
0260: 2c 20 27 20 2e 32 62 61 73 65 38 35 20 2c 20 27  , ' .2base85 , '
0270: 20 2e 33 62 61 73 65 38 35 20 2c 20 27 20 2e 34   .3base85 , ' .4
0280: 62 61 73 65 38 35 20 2c 0a 3a 20 38 35 74 79 70  base85 ,.: 85typ
0290: 65 20 28 20 61 64 64 72 20 75 20 2d 2d 20 29 0a  e ( addr u -- ).
02a0: 20 20 20 20 62 6f 75 6e 64 73 20 3f 44 4f 20 20      bounds ?DO  
02b0: 49 20 49 27 20 6f 76 65 72 20 2d 20 34 20 75 6d  I I' over - 4 um
02c0: 69 6e 20 63 65 6c 6c 73 20 2e 62 61 73 65 38 35  in cells .base85
02d0: 73 20 2b 20 70 65 72 66 6f 72 6d 20 20 34 20 2b  s + perform  4 +
02e0: 4c 4f 4f 50 20 3b 0a 0a 3a 20 62 38 35 64 69 67  LOOP ;..: b85dig
02f0: 69 74 20 28 20 63 68 61 72 20 2d 2d 20 6e 20 29  it ( char -- n )
0300: 20 24 37 46 20 75 6d 69 6e 20 63 68 61 72 73 3e   $7F umin chars>
0310: 38 35 20 2b 20 63 40 0a 20 20 20 20 64 75 70 20  85 + c@.    dup 
0320: 24 46 46 20 3d 20 21 21 6e 6f 2d 38 35 2d 64 69  $FF = !!no-85-di
0330: 67 69 74 21 21 20 3b 0a 0a 3a 20 62 61 73 65 38  git!! ;..: base8
0340: 35 3e 6e 20 28 20 61 64 64 72 20 75 20 2d 2d 20  5>n ( addr u -- 
0350: 6e 20 29 20 20 30 20 31 20 32 73 77 61 70 20 62  n )  0 1 2swap b
0360: 6f 75 6e 64 73 20 2b 44 4f 0a 09 49 20 63 40 20  ounds +DO..I c@ 
0370: 62 38 35 64 69 67 69 74 20 6f 76 65 72 20 2a 20  b85digit over * 
0380: 72 6f 74 20 2b 20 73 77 61 70 20 38 35 20 2a 0a  rot + swap 85 *.
0390: 20 20 20 20 4c 4f 4f 50 20 20 64 72 6f 70 20 3b      LOOP  drop ;
03a0: 0a 3a 20 28 62 61 73 65 38 35 3e 24 29 20 28 20  .: (base85>$) ( 
03b0: 61 64 64 72 20 75 20 2d 2d 20 61 64 64 72 27 20  addr u -- addr' 
03c0: 75 27 20 29 20 20 62 6f 75 6e 64 73 20 3f 44 4f  u' )  bounds ?DO
03d0: 0a 09 49 20 49 27 20 6f 76 65 72 20 2d 20 35 20  ..I I' over - 5 
03e0: 75 6d 69 6e 20 64 75 70 20 3e 72 20 62 61 73 65  umin dup >r base
03f0: 38 35 3e 6e 20 7b 20 7c 20 77 5e 20 78 20 7d 20  85>n { | w^ x } 
0400: 78 20 6c 65 2d 6c 21 20 78 20 72 3e 20 34 20 35  x le-l! x r> 4 5
0410: 20 2a 2f 20 74 79 70 65 0a 20 20 20 20 35 20 2b   */ type.    5 +
0420: 4c 4f 4f 50 20 3b 0a 3a 20 62 61 73 65 38 35 3e  LOOP ;.: base85>
0430: 24 20 28 20 61 64 64 72 20 75 20 2d 2d 20 61 64  $ ( addr u -- ad
0440: 64 72 27 20 75 27 20 29 20 5b 27 5d 20 28 62 61  dr' u' ) ['] (ba
0450: 73 65 38 35 3e 24 29 20 24 74 6d 70 20 3b 0a 0a  se85>$) $tmp ;..
0460: 3a 20 38 35 22 20 28 20 22 62 61 73 65 38 35 73  : 85" ( "base85s
0470: 74 72 69 6e 67 22 20 2d 2d 20 61 64 64 72 20 75  tring" -- addr u
0480: 20 29 0a 20 20 20 20 27 22 27 20 70 61 72 73 65   ).    '"' parse
0490: 20 62 61 73 65 38 35 3e 24 20 3b 0a 63 6f 6d 70   base85>$ ;.comp
04a0: 73 65 6d 3a 20 5b 63 6f 6d 70 69 6c 65 5d 20 38  sem: [compile] 8
04b0: 35 22 20 70 6f 73 74 70 6f 6e 65 20 53 4c 69 74  5" postpone SLit
04c0: 65 72 61 6c 20 3b 0a 0a 3a 20 2e 38 35 69 6e 66  eral ;..: .85inf
04d0: 6f 20 28 20 61 64 64 72 20 75 20 2d 2d 20 29 0a  o ( addr u -- ).
04e0: 20 20 20 20 3c 69 6e 66 6f 3e 20 38 35 74 79 70      <info> 85typ
04f0: 65 20 3c 64 65 66 61 75 6c 74 3e 20 3b 0a 3a 20  e <default> ;.: 
0500: 2e 38 35 77 61 72 6e 20 28 20 61 64 64 72 20 75  .85warn ( addr u
0510: 20 2d 2d 20 29 0a 20 20 20 20 3c 77 61 72 6e 3e   -- ).    <warn>
0520: 20 38 35 74 79 70 65 20 3c 64 65 66 61 75 6c 74   85type <default
0530: 3e 20 3b 0a 0a 3a 20 68 61 73 68 2d 38 35 20 28  > ;..: hash-85 (
0540: 20 61 64 64 72 20 75 20 2d 2d 20 61 64 64 72 27   addr u -- addr'
0550: 20 75 27 20 29 0a 20 20 20 20 5b 27 5d 20 38 35   u' ).    ['] 85
0560: 74 79 70 65 20 24 74 6d 70 20 68 61 73 68 2d 73  type $tmp hash-s
0570: 61 6e 69 74 69 7a 65 20 3b 0a 3a 20 63 68 61 74  anitize ;.: chat
0580: 2d 38 35 20 28 20 61 64 64 72 20 75 20 2d 2d 20  -85 ( addr u -- 
0590: 61 64 64 72 27 20 75 27 20 29 0a 20 20 20 20 5b  addr' u' ).    [
05a0: 27 5d 20 38 35 74 79 70 65 20 24 74 6d 70 20 63  '] 85type $tmp c
05b0: 68 61 74 2d 73 61 6e 69 74 69 7a 65 20 3b 0a 3a  hat-sanitize ;.:
05c0: 20 68 61 73 68 3e 66 69 6c 65 6e 61 6d 65 20 28   hash>filename (
05d0: 20 61 64 64 72 20 75 20 2d 2d 20 66 69 6c 65 6e   addr u -- filen
05e0: 61 6d 65 20 75 27 20 29 0a 20 20 20 20 68 61 73  ame u' ).    has
05f0: 68 2d 38 35 20 5b 3a 20 63 6f 6e 66 69 67 3a 6f  h-85 [: config:o
0600: 62 6a 65 63 74 73 24 20 24 2e 20 27 2f 27 20 65  bjects$ $. '/' e
0610: 6d 69 74 20 74 79 70 65 20 3b 5d 20 24 74 6d 70  mit type ;] $tmp
0620: 20 3b 0a 3a 20 2e 63 68 61 74 73 2f 20 28 20 61   ;.: .chats/ ( a
0630: 64 64 72 20 75 20 2d 2d 20 61 64 64 72 27 20 75  ddr u -- addr' u
0640: 27 20 29 0a 20 20 20 20 63 68 61 74 2d 38 35 20  ' ).    chat-85 
0650: 5b 3a 20 63 6f 6e 66 69 67 3a 63 68 61 74 73 24  [: config:chats$
0660: 20 20 24 2e 20 27 2f 27 20 65 6d 69 74 20 74 79    $. '/' emit ty
0670: 70 65 20 3b 5d 20 24 74 6d 70 20 3b 0a           pe ;] $tmp ;.