\ DUP compiler  Ian Osgood 2009

\ uses GNU Forth's XCHARS support for high ASCII support

here 26 cells + value mem	\ init when code is run

: init  here 26 cells + to mem ;

: mem@  cells mem + @ ;
: mem!  cells mem + ! ;

: mem-string ( mem xstr len -- mem+xlen )
  over + >r
  begin r@ over > while 
    xc@+ 2 pick mem!
    swap 1+ swap
  repeat
  r> 2drop ;

: compile-op ( [st] xstr len -- [st]' xstr' len' )
  over xc@
  case
  '%	of postpone DROP	endof
  '$	of postpone DUP		endof
  '\	of postpone SWAP	endof
  '^	of postpone OVER	endof
  '@	of postpone ROT		endof
  '(	of postpone >R		endof
  ')	of postpone R>		endof
  'ø	of postpone PICK	endof

  '+	of postpone +		endof
  '-	of postpone -		endof
  '*	of postpone *		endof
  '/	of postpone /MOD	endof
  '_	of postpone NEGATE	endof
  '&	of postpone AND		endof
  '|	of postpone XOR		endof
  '~	of postpone INVERT	endof
  '«	of postpone LSHIFT	endof
  '»	of postpone RSHIFT	endof
  '<	of postpone <		endof
  '=	of postpone =		endof
  '>	of postpone >		endof

  ''	of 1 /string over xc@
  	   postpone LITERAL	endof
  '"	of 1 /string 2dup '" scan \ "
  	   2swap 2 pick -
  	   postpone SLITERAL
  	   postpone mem-string  endof
  '{	of '} scan		endof

  ',	of postpone XEMIT	endof	\ EMIT and KEY are limited to ASCII
  '`	of postpone XKEY	endof
  '.	of 0 postpone LITERAL
           postpone .R		endof

  ':	of postpone mem!	endof
  ';	of postpone mem@	endof

  '[	of 2>R				\ this block literal probably only works on GNU Forth
           postpone AHEAD
  	   :NONAME
  	   2R>			endof
  ']	of 2>R
  	   postpone ;      ] >R
           postpone THEN     R>
           postpone LITERAL
           2R>			endof

  '!	of postpone EXECUTE	endof
  '?	of postpone ROT
           postpone IF
           postpone  DROP
           postpone ELSE
           postpone  NIP
           postpone THEN
           postpone EXECUTE	endof
  '#	of postpone 2>R
  	   postpone BEGIN
  	   postpone  I'		\ same as 2r@ drop
  	   postpone  EXECUTE
  	   postpone WHILE
  	   postpone  I		\ same as r@
  	   postpone  EXECUTE
  	   postpone REPEAT
  	   postpone 2RDROP	endof
  endcase ;

: compile-next ( str len -- str' len' )
  over c@ '0 '9 1+ within if
    0. 2swap >number 2swap drop
    postpone LITERAL
  else over c@ 'a 'z 1+ within if
    over c@ 'z 1+ -
    postpone LITERAL
    1 /string
  else
    compile-op
    +x/string	\ allows utf8 operators like ø
  then then ;

: compile-dup ( str len -- )
  postpone init
  begin dup while compile-next repeat 2drop
  postpone ;
  ;

: :dup ( name " code" -- )
  :
  char parse
  compile-dup ;

: :dup-file ( name file -- )
  :
  bl parse slurp-file
  compile-dup ;

\ example
:dup primes " 99 3[^^>][^^/^>[[2+][%2-3]?][%^.' ,%2-3]?]#.' ,2.%"