Artifact 87ae51f1a74630be480a1f38886241c47bf57b24:

• File base64.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: 1180)

0000: 5c 20 62 61 73 65 36 34 20 6f 75 74 70 75 74 20  \ base64 output 
0010: 28 6e 6f 74 20 74 68 65 20 75 73 75 61 6c 20 62  (not the usual b
0020: 61 73 65 36 34 2c 20 73 75 69 74 61 62 6c 65 20  ase64, suitable 
0030: 61 73 20 66 69 6c 65 6e 61 6d 65 73 29 0a 0a 3a  as filenames)..:
0040: 20 2e 62 36 34 20 28 20 6e 20 2d 2d 20 6e 27 20   .b64 ( n -- n' 
0050: 29 20 64 75 70 20 3e 72 20 36 20 72 73 68 69 66  ) dup >r 6 rshif
0060: 74 20 72 3e 20 24 33 46 20 61 6e 64 0a 20 20 20  t r> $3F and.   
0070: 20 64 75 70 20 23 31 30 20 75 3c 20 49 46 20 20   dup #10 u< IF  
0080: 27 30 27 20 2b 20 65 6d 69 74 20 20 45 58 49 54  '0' + emit  EXIT
0090: 20 20 54 48 45 4e 20 20 23 31 30 20 2d 0a 20 20    THEN  #10 -.  
00a0: 20 20 64 75 70 20 23 32 36 20 75 3c 20 49 46 20    dup #26 u< IF 
00b0: 20 27 41 27 20 2b 20 65 6d 69 74 20 20 45 58 49   'A' + emit  EXI
00c0: 54 20 20 54 48 45 4e 20 20 23 32 36 20 2d 0a 20  T  THEN  #26 -. 
00d0: 20 20 20 64 75 70 20 23 32 36 20 75 3c 20 49 46     dup #26 u< IF
00e0: 20 20 27 61 27 20 2b 20 65 6d 69 74 20 20 45 58    'a' + emit  EX
00f0: 49 54 20 20 54 48 45 4e 20 20 23 32 36 20 2d 0a  IT  THEN  #26 -.
0100: 20 20 20 20 49 46 20 20 27 5f 27 20 20 45 4c 53      IF  '_'  ELS
0110: 45 20 20 27 2d 27 20 20 54 48 45 4e 20 20 65 6d  E  '-'  THEN  em
0120: 69 74 20 3b 0a 3a 20 2e 31 62 61 73 65 36 34 20  it ;.: .1base64 
0130: 28 20 61 64 64 72 20 2d 2d 20 29 0a 20 20 20 20  ( addr -- ).    
0140: 63 40 20 2e 62 36 34 20 2e 62 36 34 20 64 72 6f  c@ .b64 .b64 dro
0150: 70 20 3b 0a 3a 20 2e 32 62 61 73 65 36 34 20 28  p ;.: .2base64 (
0160: 20 61 64 64 72 20 2d 2d 20 29 0a 20 20 20 20 6c   addr -- ).    l
0170: 65 2d 75 77 40 20 2e 62 36 34 20 2e 62 36 34 20  e-uw@ .b64 .b64 
0180: 2e 62 36 34 20 64 72 6f 70 20 3b 0a 3a 20 2e 33  .b64 drop ;.: .3
0190: 62 61 73 65 36 34 20 28 20 61 64 64 72 20 2d 2d  base64 ( addr --
01a0: 20 29 0a 20 20 20 20 6c 65 2d 75 6c 40 20 24 46   ).    le-ul@ $F
01b0: 46 46 46 46 46 20 61 6e 64 20 2e 62 36 34 20 2e  FFFFF and .b64 .
01c0: 62 36 34 20 2e 62 36 34 20 2e 62 36 34 20 64 72  b64 .b64 .b64 dr
01d0: 6f 70 20 3b 0a 43 72 65 61 74 65 20 2e 62 61 73  op ;.Create .bas
01e0: 65 36 34 73 20 27 20 64 72 6f 70 20 2c 20 27 20  e64s ' drop , ' 
01f0: 2e 31 62 61 73 65 36 34 20 2c 20 27 20 2e 32 62  .1base64 , ' .2b
0200: 61 73 65 36 34 20 2c 20 27 20 2e 33 62 61 73 65  ase64 , ' .3base
0210: 36 34 20 2c 0a 3a 20 36 34 74 79 70 65 20 28 20  64 ,.: 64type ( 
0220: 61 64 64 72 20 75 20 2d 2d 20 29 0a 20 20 20 20  addr u -- ).    
0230: 62 6f 75 6e 64 73 20 3f 44 4f 20 20 49 20 49 27  bounds ?DO  I I'
0240: 20 6f 76 65 72 20 2d 20 33 20 75 6d 69 6e 20 63   over - 3 umin c
0250: 65 6c 6c 73 20 2e 62 61 73 65 36 34 73 20 2b 20  ells .base64s + 
0260: 70 65 72 66 6f 72 6d 20 20 33 20 2b 4c 4f 4f 50  perform  3 +LOOP
0270: 20 3b 0a 0a 3a 20 62 36 34 64 69 67 69 74 20 28   ;..: b64digit (
0280: 20 63 68 61 72 20 2d 2d 20 6e 20 29 0a 20 20 20   char -- n ).   
0290: 20 27 30 27 20 2d 20 64 75 70 20 23 30 39 20 75   '0' - dup #09 u
02a0: 3c 3d 20 3f 45 58 49 54 0a 20 20 20 20 5b 20 27  <= ?EXIT.    [ '
02b0: 41 27 20 27 39 27 20 2d 20 31 2d 20 5d 4c 20 2d  A' '9' - 1- ]L -
02c0: 20 64 75 70 20 23 33 36 20 75 3c 3d 20 3f 45 58   dup #36 u<= ?EX
02d0: 49 54 0a 20 20 20 20 64 75 70 20 23 34 30 20 3d  IT.    dup #40 =
02e0: 20 49 46 20 20 64 72 6f 70 20 23 36 33 20 20 45   IF  drop #63  E
02f0: 58 49 54 20 20 54 48 45 4e 0a 20 20 20 20 5b 20  XIT  THEN.    [ 
0300: 27 61 27 20 27 5a 27 20 2d 20 31 2d 20 5d 4c 20  'a' 'Z' - 1- ]L 
0310: 2d 20 64 75 70 20 23 36 32 20 75 3c 3d 20 3f 45  - dup #62 u<= ?E
0320: 58 49 54 0a 20 20 20 20 64 72 6f 70 20 23 36 32  XIT.    drop #62
0330: 20 3b 0a 20 20 20 20 0a 3a 20 62 61 73 65 36 34   ;.    .: base64
0340: 3e 6e 20 28 20 61 64 64 72 20 75 20 2d 2d 20 6e  >n ( addr u -- n
0350: 20 29 20 20 23 30 2e 20 32 73 77 61 70 20 62 6f   )  #0. 2swap bo
0360: 75 6e 64 73 20 2b 44 4f 0a 09 49 20 63 40 20 62  unds +DO..I c@ b
0370: 36 34 64 69 67 69 74 20 6f 76 65 72 20 6c 73 68  64digit over lsh
0380: 69 66 74 20 72 6f 74 20 6f 72 20 73 77 61 70 20  ift rot or swap 
0390: 36 20 2b 0a 20 20 20 20 4c 4f 4f 50 20 20 64 72  6 +.    LOOP  dr
03a0: 6f 70 20 3b 0a 3a 20 62 61 73 65 36 34 3e 24 20  op ;.: base64>$ 
03b0: 28 20 61 64 64 72 20 75 20 2d 2d 20 61 64 64 72  ( addr u -- addr
03c0: 27 20 75 27 20 29 20 73 61 76 65 2d 6d 65 6d 20  ' u' ) save-mem 
03d0: 3e 72 20 64 75 70 20 64 75 70 20 72 40 20 62 6f  >r dup dup r@ bo
03e0: 75 6e 64 73 20 3f 44 4f 0a 09 49 20 49 27 20 6f  unds ?DO..I I' o
03f0: 76 65 72 20 2d 20 34 20 75 6d 69 6e 20 62 61 73  ver - 4 umin bas
0400: 65 36 34 3e 6e 20 6f 76 65 72 20 6c 65 2d 6c 21  e64>n over le-l!
0410: 20 33 20 2b 0a 20 20 20 20 34 20 2b 4c 4f 4f 50   3 +.    4 +LOOP
0420: 20 20 64 72 6f 70 20 72 3e 20 33 20 34 20 2a 2f    drop r> 3 4 */
0430: 20 3b 0a 0a 3a 20 36 34 22 20 28 20 22 62 61 73   ;..: 64" ( "bas
0440: 65 36 34 73 74 72 69 6e 67 22 20 2d 2d 20 61 64  e64string" -- ad
0450: 64 72 20 75 20 29 0a 20 20 20 20 27 22 27 20 70  dr u ).    '"' p
0460: 61 72 73 65 20 62 61 73 65 36 34 3e 24 20 3b 0a  arse base64>$ ;.
0470: 63 6f 6d 70 73 65 6d 3a 20 5b 63 6f 6d 70 69 6c  compsem: [compil
0480: 65 5d 20 36 34 22 20 70 6f 73 74 70 6f 6e 65 20  e] 64" postpone 
0490: 53 4c 69 74 65 72 61 6c 20 3b 0a 0a              SLiteral ;..