screens.fs 3.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142
  1. ( 00: JCB 08:33 04/24/11)
  2. : immediate voc @ 3 - dup c@ 80 or swap c! f;
  3. : ; semis# , 0 state ! f; immediate
  4. : exit semis# , ; immediate
  5. : \ source nip >in ! ; immediate
  6. : allot dp +! ;
  7. : create head, bc-var# c, ;
  8. : variable head, bc-var# c, 0 , ;
  9. : 2variable head, bc-var# c, 0 , 0 , ;
  10. : constant head, bc-const# c, , ;
  11. : compile, , ;
  12. : cell+ 2 + ; : 2* 2 * ; : cells 2* ;
  13. ( 01: branching JCB 08:15 04/24/11)
  14. : ahead branch# , here 7777 , ;
  15. : 0ahead 0branch# , here 7777 , ;
  16. : resolve here swap ! ; \ resolve stacked ref to HERE
  17. : begin here ; immediate
  18. : again branch# , , ; immediate
  19. : until 0branch# , , ; immediate
  20. : while 0ahead ; immediate
  21. : repeat swap branch# , , resolve ; immediate
  22. : if 0ahead ; immediate
  23. : else ahead swap resolve ; immediate
  24. : then resolve ; immediate
  25. ( 02: parse JCB 08:16 04/24/11)
  26. : parse \ ( char -- ca u )
  27. source>in
  28. advance
  29. over >r
  30. rot >r
  31. begin
  32. over c@ r@ <> over 0<> and
  33. while
  34. advance
  35. repeat
  36. r> 2drop
  37. r> tuck - 1 >in +!
  38. ;
  39. ( 03: compilation JCB 08:17 04/24/11)
  40. : [ 0 state ! ; immediate
  41. : ] 1 state ! ;
  42. : literal literal# , , ; immediate
  43. : char parse-word drop c@ ;
  44. : ' parse-word sfind ;
  45. : ['] literal# , ' , ; immediate
  46. : postpone
  47. parse-word sfind
  48. dup isimmediate invert if
  49. literal# , , ['] ,
  50. then , ; immediate
  51. : [char] char postpone literal ; immediate
  52. : ( [char] ) parse 2drop ; immediate
  53. : halt begin again ; ' halt (quit) !
  54. ( 04: debug JCB 08:17 04/24/11)
  55. : dump
  56. over hex4 bounds
  57. begin 2dup xor
  58. while space dup c@ hex2 1+
  59. repeat 2drop cr ;
  60. : isxt voc @ begin 2dup = if 2drop true exit then
  61. 2 - @ dup 0= until nip ;
  62. : typext dup isxt if name? type else hex4 then ;
  63. : seelast [char] : emit space voc @ name? type
  64. here voc @ 1+ begin
  65. 2dup xor
  66. while space dup @ typext cell+
  67. repeat cr 2drop ;
  68. ( 05: strings JCB 08:17 04/24/11)
  69. : (sliteral)
  70. r> count 2dup + >r ;
  71. : s"
  72. [char] " parse
  73. postpone (sliteral) dup c, s, ; immediate
  74. : ." postpone s" postpone type ; immediate
  75. : .( [char] ) parse type cr ; immediate
  76. : (next) 1- ?dup 0= ;
  77. : next postpone (next) postpone until ; immediate
  78. ( 06: move JCB 08:18 04/24/11)
  79. : cmove ( c-addr1 c-addr2 u -- )
  80. begin
  81. dup
  82. while
  83. >r over c@ over c!
  84. 1+ swap 1+ swap
  85. r> 1-
  86. repeat
  87. drop 2drop
  88. ;
  89. ( 07: create does> JCB 08:18 04/24/11)
  90. : (create) r> cell+ ;
  91. : (does) r> dup cell+ swap @ >r ;
  92. : create
  93. head, bc-col# c,
  94. ['] (create) , 0 , ;
  95. : does>
  96. r> voc @ 1+
  97. ['] (does) over ! cell+ ! ;
  98. : :noname
  99. here bc-col# c, ] ;
  100. ( 08: welcome JCB 08:18 04/24/11)
  101. \ screen \ 8
  102. .( gdforth 0.0.1)
  103. here hex4 cr
  104. ' quit (quit) !
  105. ( 09: DNA JCB 08:19 04/24/11)
  106. : dna@ ( -- u ) 8018 c@ ;
  107. : dna! ( u -- ) 8008 c! ;
  108. : dnaclk ( u -- ) dup dna! 1+ dna! ;
  109. : dnaread ( ) 4 dnaclk ;
  110. : dnashift ( ) 2 dnaclk ;
  111. : dnabit ( u -- u ) 2* dna@ + dnashift ;
  112. : dnabyte ( -- u ) \ read byte from DNA
  113. 0 8 begin >r dnabit r> next ;
  114. : dna ( ca -- ) \ write 7 byte DNA at ca
  115. dnaread dnashift
  116. 7 begin
  117. >r dnabyte over c! 1+ r>
  118. next drop ;
  119. \ 7F00 dna 7F00 7 dump
  120. ( 10: SPI and flash JCB 08:19 04/24/11)
  121. char J IOMODE c! spi-cold
  122. \ flash-status hex2 cr
  123. : showblk ( u -- )
  124. spi-sel
  125. 03 >spi
  126. flash-page
  127. 400 400 bounds begin
  128. 0 spi-xfer over c!
  129. 1+ 2dup =
  130. until 2drop spi-unsel ;
  131. \ 0 showblk
  132. \ here hex4 cr
  133. quit