memtest.fs 805 B

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354
  1. start-microcode memtest
  2. 32 constant sp
  3. 0 constant false ( 6.2.1485 )
  4. : true ( 6.2.2298 ) d# -1 ;
  5. : 1+ d# 1 + ;
  6. : rot >r swap r> swap ;
  7. : -rot swap >r swap r> ;
  8. : 0= d# 0 = ;
  9. : tuck swap over ;
  10. : 2drop drop drop ;
  11. : ?dup dup if dup then ;
  12. : 2* d# 2 * ;
  13. : summit
  14. h# 0 c@
  15. h# 1 c@ +
  16. h# 2 c@ +
  17. h# 3 c@ +
  18. h# 4 c@ +
  19. h# 5 c@ +
  20. h# 6 c@ +
  21. h# 7 c@ +
  22. h# 8 c@ +
  23. h# 9 c@ +
  24. d# 765
  25. \ d# 550
  26. over xor
  27. if
  28. h# DEAD begin again
  29. else
  30. drop
  31. then
  32. ;
  33. : move ( c-addr1 c-addr2 u -- )
  34. begin
  35. >r
  36. over noop noop c@ over c!
  37. 1+ swap 1+ swap
  38. r> 1- dup 0=
  39. until
  40. drop 2drop
  41. ;
  42. : main
  43. begin
  44. h# 0 h# 16 d# 10 move
  45. h# 16 h# 0 d# 10 move
  46. summit
  47. again
  48. ;
  49. end-microcode