LIBRARY.fth (8107B)
1 \ A library of useful words for Forth6 cross-compiled targets 2 3 (( 4 Copyright (c) 1988-2004 5 MicroProcessor Engineering 6 133 Hill Lane 7 Southampton SO15 5AF 8 England 9 10 tel: +44 (0)2380 631441 11 fax: +44 (0)2380 339691 12 net: mpe@mpeforth.com 13 tech-support@mpeforth.com 14 web: www.mpeforth.com 15 16 17 To do 18 ===== 19 DocGen everything 20 21 22 Change history 23 ============== 24 20040216 MPE006 Added words from LIB.FTH and deleted LIB.FTH. 25 Added SETCONSOLE. 26 20011113 SFP005 Added INIT-IO 27 20000112 SFP004 Added S.DEC and SN.DEC 28 19981023 MSD003 Removed the LIBRARIES and END-LIBS invocations as 29 they should have been placed outside this source. 30 (Not flagged as they were just deletions.) 31 19981023 MSD002 Added .HEX as a synonym for U.HEX. 32 19981023 MSD001 Remove the use of S>D in the *hex* display wordset. 33 In this case, we do *not* want the top bit to be 34 rippled across the most significant cell since 35 what we are displaying is *hex*. 36 )) 37 38 39 \ ******************** 40 \ *S Memory mapped I/O 41 \ ******************** 42 43 [required] init-io [if] 44 : init-io \ addr -- 45 \ *G Copy the contents of an I/O set up table to an I/O device. 46 \ ** Each element of the table is of the form addr (cell) followed 47 \ ** by data (cell). The table is terminated by an address of 0. 48 \ ** A table of a single 0 address performs no action. Note 49 \ ** that this word is for memory-mapped I/O only. 50 begin 51 dup @ 52 while 53 dup 2@ ! 2 cells + 54 repeat 55 drop 56 ; 57 [then] 58 59 60 \ ************** 61 \ *S Generic I/O 62 \ ************** 63 64 [required] ConsoleIO [if] 65 : ConsoleIO \ -- 66 \ *G Use the default console defined by CONSOLE as the 67 \ ** current terminal device. 68 console SetConsole 69 ; 70 [then] 71 72 [required] SetConsole [if] 73 : SetConsole \ device -- 74 \ *G Sets KEY and EMIT and frieds to use the given device 75 \ ** for terminal I/O. 76 dup ipvec ! opvec ! 77 ; 78 [then] 79 80 81 \ ********** 82 \ *S Strings 83 \ ********** 84 85 [required] bounds [if] 86 : BOUNDS \ addr len -- addr+len addr 87 \ *G Modify the address and length parameters to provide an end-address 88 \ ** and start-address pair suitable for a DO ... LOOP construct. 89 over + swap 90 ; 91 [then] 92 93 [required] Erase [if] 94 : Erase \ addr n -- 95 \ *G Fill U bytes of memory from A-ADDR with 0. 96 0 Fill ; 97 [then] 98 99 [required] 2@ [if] 100 : 2@ \ addr -- x1 x2 101 \ *G Fetch and return the two CELLS from memory ADDR and ADDR+sizeof(CELL). 102 \ ** The cell at the lower address is on the top of the stack. 103 dup cell+ @ swap @ 104 ; 105 [then] 106 107 [required] 2! [if] 108 : 2! \ x1 x2 addr -- ; store into DATA memory 109 \ *G Store the two CELLS x1 and x2 at memory ADDR. 110 \ ** X2 is stored at ADDR and X1 is stored at ADDR+CELL. 111 swap over ! cell+ ! 112 ; 113 [then] 114 115 116 \ ****************** 117 \ *S Numeric display 118 \ ****************** 119 120 [required] hold 121 [required] sign or 122 [required] # or 123 [required] #s or 124 [required] <# or 125 [required] #> or 126 [if] 127 128 $80 equ holdsize 129 $80 equ padsize 130 131 holdsize buffer: holdarea 132 padsize buffer: pad 133 134 variable hld 135 136 : HOLD \ char -- 137 -1 hld +! hld @ c! 138 ; 139 140 : SIGN \ n -- 141 0< if [char] - hold then 142 ; 143 144 : # \ ud1 -- ud2 145 base @ mu/mod rot 9 over < 146 if 7 + then 147 [char] 0 + hold 148 ; 149 150 : #S \ ud1 -- ud2 151 begin # 2dup or 0= until 152 ; 153 154 : <# \ -- 155 pad hld ! 156 ; 157 158 : #> \ xd -- c-addr u 159 2drop hld @ pad over - 160 ; 161 162 [then] 163 164 \ A set of words to display a cell's value, saving and restoring BASE 165 \ during the period that it is doing so. 166 167 [required] .hex \ MSD002 168 [required] u.hex or \ MSD002 169 [required] uN.hex or 170 [required] u2.hex or 171 [required] u4.hex or 172 [required] u6.hex or 173 [required] u8.hex or 174 [required] $u.hex or 175 [required] $uN.hex or 176 [required] $u2.hex or 177 [required] $u4.hex or 178 [required] $u6.hex or 179 [required] $u8.hex or 180 [if] 181 182 : u.hex \ value -- ; Variable width. 183 base @ swap hex 184 0 <# #S #> type \ MSD001 185 base ! 186 ; 187 188 : uN.hex \ value width -- ; User-specified width. 189 base @ -rot hex 190 swap 0 \ MSD001 191 <# rot 0 ?do # loop #> type 192 base ! 193 ; 194 195 : .hex u.hex ; ( value -- ) \ MSD002 196 : u2.hex 2 uN.hex ; ( value -- ) 197 : u4.hex 4 uN.hex ; ( value -- ) 198 : u6.hex 6 uN.hex ; ( value -- ) 199 : u8.hex 8 uN.hex ; ( value -- ) 200 201 : $u.hex ." $" u.hex ; ( value -- ) 202 : $uN.hex ." $" uN.hex ; ( value width -- ) 203 : $u2.hex ." $" u2.hex ; ( value -- ) 204 : $u4.hex ." $" u4.hex ; ( value -- ) 205 : $u6.hex ." $" u6.hex ; ( value -- ) 206 : $u8.hex ." $" u8.hex ; ( value -- ) 207 208 [then] 209 210 [required] u.dec 211 [required] uN.dec or 212 [required] s.dec or 213 [required] sN.dec or 214 [required] u2.dec or 215 [required] u4.dec or 216 [required] u6.dec or 217 [required] u8.dec or 218 [if] 219 220 : u.dec \ value -- ; Variable width. 221 base @ swap decimal 222 0 <# #S #> type 223 base ! 224 ; 225 226 : uN.dec \ value width -- ; User-specified width. 227 base @ -rot decimal 228 swap 0 229 <# rot 0 ?do # loop #> type 230 base ! 231 ; 232 233 : u2.dec 2 uN.dec ; ( value -- ) 234 : u4.dec 4 uN.dec ; ( value -- ) 235 : u6.dec 6 uN.dec ; ( value -- ) 236 : u8.dec 8 uN.dec ; ( value -- ) 237 238 : s.dec \ value -- ; Variable width. 239 base @ swap decimal 240 s>d tuck dabs <# #S rot sign #> type 241 base ! 242 ; 243 244 : sN.dec \ value width -- ; User-specified width. 245 >r 246 base @ swap decimal 247 s>d tuck dabs 248 <# r> 0 ?do # loop rot sign #> type 249 base ! 250 ; 251 252 [then] 253 254 [required] u.both [if] 255 : u.both \ value -- 256 dup u.dec ." =" $u.hex ; 257 [then] 258 259 [required] .ascii [if] 260 : .ascii \ char -- ; 261 dup bl < 262 over [char] ~ > or 263 if drop [char] . endif 264 emit 265 ; 266 [then] 267 268 269 \ ****************** 270 \ *S Debugging tools 271 \ ****************** 272 273 [required] ? [if] : ? @ . ; [then] 274 [required] hex [if] : hex #16 base ! ; [then] 275 [required] decimal [if] : decimal #10 base ! ; [then] 276 [required] octal [if] : octal #8 base ! ; [then] 277 [required] binary [if] : binary #2 base ! ; [then] 278 [required] bl [if] $20 constant bl [then] 279 [required] space [if] : space bl emit ; [then] 280 [required] s>d [if] : dup 0< if -1 else 0 then ; [then] 281 [required] depth [if] : depth s0 @ sp@ - cell- cell/ ; [then] 282 [required] cell- [if] : cell- cell - ; [then] 283 [required] cell+ [if] : cell+ cell + ; [then] 284 [required] cells [if] : cells cell * ; [then] 285 [required] led-init [if] : led-init ; [then] 286 [required] led-on [if] : led-on ; [then] 287 [required] led-off [if] : led-off ; [then] 288 [required] . [if] : . s.dec space ; [then] 289 [required] abort [if] : abort begin cr .cpu cr again ; [then] 290 [required] true [if] -1 constant true [then] 291 [required] false [if] 0 constant false [then] 292 293 [required] .shex [if] 294 : .shex ( -- ) 295 [char] [ emit space 296 depth 297 dup 0> 298 if 299 0 do 300 [char] $ emit 301 depth i - 1- pick u.hex 302 space 303 loop 304 else 305 drop 306 then 307 [char] ] emit 308 ; 309 [then] 310 311 [required] dump [if] 312 : dump ( addr u -- ) 313 bounds 314 do 315 cr i u8.hex space 316 i $04 + i $00 + do i c@ space u2.hex loop 317 space 318 i $08 + i $04 + do i c@ space u2.hex loop 319 space 320 i $0c + i $08 + do i c@ space u2.hex loop 321 space 322 i $10 + i $0c + do i c@ space u2.hex loop 323 space 324 i $10 + $00 i + do i c@ .ascii loop 325 $10 +loop 326 cr 327 ; 328 [then] 329