kernel72lite.fth (57782B)
1 \ MPE High level ANS kernel for embedded systems 2 3 (( 4 Released for use with the MPE Forth Cross Compiler by: 5 and copyright (c) 1998-2004, 2006, 2008, 2010, 2012, 2013 6 7 MicroProcessor Engineering 8 133 Hill Lane 9 Southampton SO15 5AF 10 England 11 12 tel: +44 (0)23 8063 1441 13 fax: +44 (0)23 8033 9691 14 net: mpe@mpeforth.com 15 tech-support@mpeforth.com 16 web: www.mpeforth.com 17 18 19 To do 20 ===== 21 Factor COLD into initialisation and Forth entry. 22 23 Remove in-place usage of UPPER because it can cause writes to Flash. 24 UCMOVE may be useful. 25 26 Change NEXT-CASE to be compatible with VFX Forth. 27 28 Remove uses of PAD where possible. 29 30 Change error codes to ANS codes. 31 32 33 Change history 34 ============== 35 20140122 SFP016 EMPTY ends with a reboot. 36 20131219 SFP015 Removed WIDTH. Added ORG. 37 Rewrote NUMBER? and friends. 38 20120825 SFP014 Converted to Lite form. 39 20101215 SFP013 Made >NUMBER case-insensitive. 40 20100623 MPE012 Changed POSTPONE to be smaller and less sensitive 41 to target architecture. 42 20090704 MPE011 Improved overlap detection in MOVE so that we can 43 make better use of optimised CMOVEs, e.g. ARM. 44 20081218 SFP010 Removed [IODEV and IODEV]. 45 Added [IO and IO]. 46 20060307 MPE009 Added compiler macro for >THREADS. 47 20040401 MPE008 Added NEXTCASE. 48 20040225 MPE007 Bulletproofed PLACE. 49 20040218 MPE006 Added SETCONSOLE for 32 bit systems. 50 20030320 SFP005 Added FLUSHKEYS for 32 bit tagets. 51 Modified ACCEPT and HALT? to ignore LF characters. 52 20020910 SFP004 Removed ERROR and ?ERROR 53 20020704 SFP003 Corrected REPEAT - how did this survive so long? 54 20011112 SFP002 Unmarked: start of DOCGEN documentation - an ongoing 55 process. 56 20000614 SFP001 Unmarked reordering to reduce forward refs and size. 57 )) 58 59 60 \ ========= 61 \ *! kernel72lite 62 \ *T High level kernel - kernel72lite.fth. 63 \ ========= 64 \ *P The Forth kernel words documented here are entirely written 65 \ ** in high-level Forth. The kernel is reduced in size to match 66 \ ** available code size in small devices. 67 68 only forth definitions 69 decimal 70 71 \ ----------------- 72 \ character equates 73 \ ----------------- 74 75 $07 equ ABELL \ sound 76 $08 equ BSIN \ back space from key 77 $7F equ DELIN \ delete from key 78 $08 equ BSOUT \ back space for emit 79 $09 equ ATAB \ tab 80 $0D equ ACR \ carriage return 81 $0A equ ALF \ line feed 82 $0C equ FFEED \ form feed 83 $20 equ ABL \ space 84 $2E equ ADOT \ . 85 86 87 \ ***************** 88 \ *S User variables 89 \ ***************** 90 91 internal 92 variable next-user \ -- addr 93 \ *G Next valid offset for a *\fo{USER} variable created by *\fo{+USER}. 94 next-user off 95 external 96 97 interpreter 98 : +user-offset \ -- offset ; user offset of next +USER allocation 99 next-user @ 100 ; 101 102 : +user \ size -- 103 \ *G Used in the cross compiler to create a *\fo{USER} variable 104 \ ** *\i{size} bytes long at the next available offset and 105 \ ** updates that offset. 106 next-user @ user 107 next-user +! 108 ; 109 target 110 111 tcb-size +user SELF \ task identifier and TCB 112 \ *G When multitasking is installed, 113 \ ** the task control block for a task occupies *\fo{TCB-SIZE} bytes at 114 \ ** the start of the user area. Thus the user area pointer 115 \ ** also acts as a pointer to the task control block. 116 +user-offset equ s0-offset 117 cell +user S0 \ base of data stack 118 \ *G Holds the initial setting of the data stack pointer. 119 \ ** N.B. *\fo{S0}, *\fo{R0}, *\fo{#TIB} and *\fo{'TIB} must be 120 \ ** defined in that order. 121 +user-offset equ r0-offset 122 cell +user R0 \ base of return stack 123 \ *G Holds the initial setting of the return stack pointer. 124 cell +user #TIB \ number of chars currently in TIB 125 \ *G Holds the number of characters currently in *\fo{TIB}. 126 cell +user 'TIB \ address of TIB 127 \ *G Holds the address of *\fo{TIB}, the terminal input buffer. 128 cell +user >IN \ offset into TIB 129 \ *G Holds the current character position being processed in the 130 \ ** input stream. 131 cell +user XON/XOFF \ true if XON/XOFF protocol in use 132 \ *G True when console is using XON/XOFF protocol. 133 cell +user ECHOING \ true if echoing 134 \ *G True when console is echoing input characters. 135 cell +user OUT \ number of chars displayed on current line 136 \ *G Holds the number of chars displayed on current output line. 137 \ ** Reset by CR. 138 \ ** internal 139 cell +user BASE \ current numeric conversion base 140 \ *G Holds the current numeric conversion base. 141 \ ** INTERNAL. 142 cell +user HLD \ used during number formatting 143 \ *G Holds data used during number formatting. 144 \ ** INTERNAL. 145 cell +user HANDLER \ used in catch and throw 146 \ *G Holds the address of the previous exception frame. 147 external 148 cell +user DPL \ position of double number character id 149 \ *G Holds the number of characters after the double number indicator 150 \ ** character. *\fo{DPL} is initialised to -1, which indicates a 151 \ ** single number, and is incremented for each character after 152 \ ** the separator. 153 cell +user OPVEC \ output vector 154 \ *G Holds the address of the I/O vector for the current output device. 155 cell +user IPVEC \ input vector 156 \ *G Holds the address of the I/O vector for the current input device. 157 internal 158 cell +user 'AbortText \ Address of text from ABORT" 159 \ *G Set by the run-time action of *\fo{ABORT"} to hold the address 160 \ ** of the counted string used by *\fo{ABORT" <text>"}. 161 external 162 32bit? [if] \ size of hold buffer 163 #68 \ depends on stack width in bits 164 [else] 165 #34 166 [then] 167 dup next-user +! equ PICNUMSIZE 168 #80 chars dup +user PAD 169 \ *G A temporary string scratch buffer. 170 equ PADSIZE 171 172 cr ." Kernel USER area size is " next-user @ . 173 174 175 \ ************** 176 \ *S System data 177 \ ************** 178 179 \ ============ 180 \ *N Constants 181 \ ============ 182 183 $20 constant BL \ -- char 184 \ *G A blank space character. 185 186 $40 equ C/L \ characters/line for display functions 187 188 $11 equ XON \ XON for flow control 189 $13 equ XOFF \ XOFF for flow control 190 191 2 equ #VOCS \ maximum number of vocabularies in search order 192 #VOCS cells equ VSIZE \ maximum size of search order area CONTEXT 193 194 195 \ ============ 196 \ *N System variables and data 197 \ ============ 198 \ *P Note that *\fo{FENCE}, *\fo{DP}, *\fo{RP} and *\fo{VOC-LINK} 199 \ ** must be declared in that order. 200 201 ihere equ DefStart \ --addr 202 \ +G Start address of saved Forth state. 203 204 variable FENCE \ -- addr 205 \ *G End of the protected dictionary. 206 variable DP \ -- addr 207 \ *G Flash dictionary pointer. 208 variable RP \ -- addr 209 \ *G RAM dictionary pointer. 210 internal 211 variable VOC-LINK \ -- addr 212 \ *G An INTERNAL variable that links vocabularies. 213 \ ** INTERNAL. 214 variable CSP \ -- addr 215 \ +G Preserved stack pointer for compile time error checking. 216 \ +* INTERNAL. 217 external 218 variable xDP DP xDP ! \ -- addr 219 \ *G Holds the address of the current dictionary pointer, 220 \ ** *\fo{DP} or *\fo{RP}. 221 internal 222 variable STATE \ -- addr 223 \ +G Interpreting=0 or compiling=-1. 224 variable CURRENT \ -- addr 225 \ +G Vocabulary/wordlist in which to put new definitions 226 variable CONTEXT \ -- addr 227 \ +G Search order array. 228 vsize cell - allot-ram \ search order array 229 external 230 variable LAST \ -- addr 231 \ *G Points to name field of last definition 232 internal 233 defer start-action \ -- 234 \ +G The initial action of an application. 235 assign noop to-do start-action 236 vocabulary FORTH 237 \ +G The standard general purpose vocabulary. INTERNAL. 238 ' forth >body @ equ FORTH-WORDLIST \ -- wid 239 FORTH-WORDLIST @ 1+ cells equ /Forth-Wordlist \ -- len 240 241 ihere DefStart - equ /DefStart 242 \ The initial kernel Forth state is saved in the first INFO sector. 243 \ The application Forth state is saved in the second info sector. 244 245 variable PrevName \ -- addr 246 \ +G Holds the name field of the previous word in the thread 247 \ +* between *\fo{HIDE} and *\fo{REVEAL} 248 249 external 250 251 252 \ ======================== 253 \ *S Vectored I/O handling 254 \ ======================== 255 256 \ =============== 257 \ *N Introduction 258 \ =============== 259 \ *P The standard console Forth I/O words (*\fo{KEY?}, *\fo{KEY}, 260 \ ** *\fo{EMIT}, *\fo{TYPE} and *\fo{CR}) can be used with any I/O 261 \ ** device by placing the address of a table of xts in the 262 \ ** *\fo{USER} variables *\fo{IPVEC} and *\fo{OPVEC}. *\fo{IPVEC} 263 \ ** (input vector) controls the actions of *\fo{KEY?} and *\fo{KEY}, 264 \ ** and *\fo{OPVEC}(output vector) controls the actions of *\fo{EMIT}, 265 \ ** *\fo{TYPE} and *\fo{CR}. 266 \ ** Adding a new device is matter of writing the five primitives, 267 \ ** building the table, and storing the address of the table in 268 \ ** the pointers *\fo{IPVEC} and *\fo{OPVEC} to make the new 269 \ ** device active. Any initialisation must be performed before 270 \ ** the device is made active. 271 272 \ *P Note that for the output words (*\fo{EMIT}, *\fo{TYPE} and 273 \ ** *\fo{CR}) the *\fo{USER} variable *\fo{OUT} is handled in the 274 \ ** kernel before the funtion in the table is called. 275 276 \ ========================== 277 \ *N Building a vector table 278 \ ========================== 279 \ *P The example below is taken from an ARM implementation. 280 \ *E create Console1 \ -- addr 281 \ ** ' serkey1i , \ -- char 282 \ ** ' serkey?1i , \ -- flag 283 \ ** ' seremit1 , \ char -- 284 \ ** ' sertype1 , \ c-addr len -- 285 \ ** ' serCR1 , \ -- 286 \ ** 287 \ ** Console1 opvec ! Console1 ipvec ! 288 289 \ ==================== 290 \ *N Generic I/O words 291 \ ==================== 292 293 (( \ easier to expand 294 : ipfunc \ n -- ; i*x -- j*x 295 create 296 cells , 297 does> 298 @ ipvec @ + @ execute 299 ; 300 301 : opfunc \ n -- ; i*x -- j*x 302 create 303 cells , 304 does> 305 @ opvec @ + @ execute 306 ; 307 308 0 ipfunc KEY \ -- char ; receive char 309 1 ipfunc KEY? \ -- flag ; check receive char 310 2 opfunc EMIT \ -- char ; display char 311 3 opfunc TYPE \ caddr len -- ; display string 312 4 opfunc CR \ -- ; display new line 313 5 opfunc TYPEC \ caddr len -- ; display string in code space (Harvard only) 314 )) 315 316 : key \ -- char ; receive char 317 \ *G Wait until the current input device receives a character and 318 \ ** return it. 319 ipvec @ ( 0 cells + ) @ execute ; 320 : KEY? \ -- flag ; check receive char 321 \ *G Return true if a character is available at the current input 322 \ ** device. 323 ipvec @ cell+ @ execute ; 324 : EMIT \ -- char ; display char 325 \ *G Display char on the current I/O device. *\fo{OUT} is incremented 326 \ ** before executing the vector function. 327 1 out +! 328 opvec @ [ 2 cells ] literal + @ execute ; 329 : TYPE \ caddr len -- ; display string 330 \ *G Display/write the string on the current output device. 331 \ ** *\i{Len} is added to *\fo{OUT} before executing the vector 332 \ ** function. 333 dup out +! 334 opvec @ [ 3 cells ] literal + @ execute ; 335 : CR \ -- ; display new line 336 \ *G Perform the equivalent of a CR/LF pair on the current output 337 \ ** device. *\fo{OUT} is zeroed. before executing the vector 338 \ ** function. 339 out off 340 opvec @ [ 4 cells ] literal + @ execute ; 341 342 : SPACE \ -- 343 \ *G Output a blank space (ASCII 32) character. 344 bl emit 345 ; 346 347 : SPACES \ n -- 348 \ *G Output 'n' spaces, where 'n' > 0. 349 \ ** If 'n' < 0, no action is taken. 350 0 max 0 ?do space loop 351 ; 352 353 354 \ ************************ 355 \ *S Laying data in memory 356 \ ************************ 357 \ *P These words are used to control and place data in memory. 358 \ ** Note that the Forth system compiles headers and code into 359 \ ** Flash memory. 360 361 : HERE \ -- addr 362 \ *G Return the current dictionary pointer which is the first 363 \ ** address-unit of free space within the system. 364 xdp @ @ 365 ; 366 367 : ORG \ addr -- 368 \ *G Set the current dictionary pointer. 369 xdp @ ! 370 ; 371 372 : ALLOT \ n -- 373 \ *G Allocate N address-units of data space from the current value of 374 \ ** *\fo{HERE} and move the pointer. 375 xdp @ +! 376 ; 377 378 : RHERE \ -- addr 379 \ *G Return the current RAM dictionary pointer. 380 rp @ 381 ; 382 383 : RALLOT \ n -- 384 \ *G Allocate n bytes of RAM from *\fo{RHERE} and move the pointer. 385 rp +! 386 ; 387 388 : ROM \ -- 389 \ *G *\fo{HERE}, *\fo{ORG}, *\fo{ALLOT}, *\fo{,} and friends, are 390 \ ** set to use the Flash dictionary pointer. This is the default. 391 DP xDP ! 392 ; 393 394 : RAM \ -- 395 \ *G *\fo{HERE}, *\fo{ORG} and *\fo{ALLOT} are set to use 396 \ ** the RAM dictionary pointer. Use in the form: 397 \ *C RAM ... ROM 398 RP xDP ! 399 ; 400 401 internal 402 : [ROM \ -- x 403 \ +G Force ROM and save state. 404 xDP @ ROM 405 ; 406 407 : ROM] \ x -- 408 \ +G Restore ROM/RAM state. 409 xDP ! 410 ; 411 412 : ROM? \ -- flag 413 \ +G True if ROM set. 414 xDP @ DP = 415 ; 416 external 417 418 aligning? [if] 419 [undefined] aligned [if] 420 : aligned \ addr -- addr' 421 \ *G Given an address pointer this word will return the next 422 \ ** *\fo{ALIGNED} address subject to system wide alignment 423 \ ** restrictions. 424 [ cell 1- ] literal + 425 [ cell negate ] literal and 426 ; 427 [then] 428 429 : ALIGN \ -- 430 \ *G *\fo{ALIGN} dictionary pointer using the same rules as 431 \ ** *\fo{ALIGNED}. 432 here aligned org 433 ; 434 [else] 435 : aligned \ addr -- addr' ; NOOP on this system 436 ; immediate 437 438 : align \ -- ; force alignment if required - NOOP on this system 439 ; immediate 440 441 compiler 442 : aligned ; 443 : align ; 444 target 445 [then] 446 447 : , \ x -- 448 \ *G Place the CELL value X into the dictionary at *\fo{HERE} and 449 \ ** increment the pointer. 450 here !f cell allot 451 ; 452 453 32bit? [if] 454 : w, \ x -- 455 \ *G Place the 16 bit value X into the dictionary at *\fo{HERE} and 456 \ ** increment the pointer. 457 here w!f 2 allot 458 ; 459 [then] 460 461 : C, \ b -- 462 \ *G Place an 8 bit byte into the dictionary at *\fo{HERE} and 463 \ ** increment the pointer. Note that the STM32 Flash must be 464 \ ** programmed two bytes at a time, so you cannot repeatedly 465 \ ** use *\fo{C,} to program the Flash. 466 here c!f 1 allot 467 ; 468 469 470 \ ************************ 471 \ *S Dictionary management 472 \ ************************ 473 \ *P The Forth header is laid out as below. The start and end of 474 \ ** the header are aligned at cell boundaries. 475 \ *E Link | Count | <name> 476 \ ** ---------------------- 477 \ ** Cell | Byte | n Bytes 478 \ ** ---------------------- 479 \ *D Link Also called LFA. This field contains the address of the 480 \ ** of the next count byte in the same thread of the wordlist. 481 \ *D Count/Ctrl The bottom five bits contain the length (0..31) 482 \ ** of the name in bytes. The top three bits are used 483 \ ** as follows: 484 \ *E Bit 7 Always set 485 \ ** Bit 6 Immediate bit (0=immediate) 486 \ ** Bit 5 Reserved 487 \ *D <name> A string of ASCII characters which make up the 488 \ ** name of the word.. 489 490 compiler 491 : N>LINK \ a-addr -- a-addr' 492 cell- 493 ; 494 495 : LINK>N \ a-addr -- a-addr' 496 cell+ 497 ; 498 499 : >#threads ; \ -- ; compiler treats this as an immediate noop 500 501 : >THREADS \ wid -- a-addr ; MPE009 502 >#threads cell+ 503 ; 504 505 : >vocname 506 cell- 507 ; 508 509 : >VOC-LINK \ wid -- a-addr 510 2 cells - 511 ; 512 513 : latest ( -- caddr ) Last @ ; 514 515 target 516 517 internal 518 : LATEST \ -- c-addr 519 \ +G Return the address of the name field of the last definition. 520 Last @ 521 ; 522 523 : HIDE \ -- 524 \ +G Unhook the last word from the current thread and save it 525 \ +* in *\fo{PrevName}. 526 Last @ dup PrevName ! \ save previous state 527 n>link @ Last ! \ use previous word 528 ; 529 : REVEAL \ -- 530 \ +G Relink the hidden word. 531 PrevName @ Last ! 532 ; 533 external 534 535 -short-branches 536 : FIND \ c-addr -- c-addr 0|xt 1|xt -1 537 \ *G Perform the *\fo{SEARCH-WORDLIST} operation on all wordlists 538 \ ** within the current search order. This definition takes a 539 \ ** counted string rather than a *\i{c-addr/u} pair. The counted 540 \ ** string is returned as well as the 0 on failure. 541 dup count upper \ make sure search text is upper case 542 dup c@ if \ if there is any search text 543 context vsize bounds \ for all word lists in search order: 544 do 545 dup count i @ search-wordlist \ search word list for text 546 ?dup if \ if text is found then bail out now 547 rot drop \ discard text address 548 unloop exit 549 then 550 cell +loop 551 then 552 0 553 ; 554 +short-branches 555 556 : .NAME \ nfa -- 557 \ *G Display a definition's name given an NFA. 558 count $1F and type space 559 ; 560 561 internal 562 : header, \ -- 563 \ +G Create a new header in the dictionary. INTERNAL 564 bl word count 2dup upper \ convert to upper case - must be in RAM 565 \ check for redefinitions 566 2dup current @ search-wordlist \ see if name exists 567 if >name CR .NAME ." is redefined " then 568 \ form hash and create link 569 align \ force DP to even address 570 over c@ over + \ -- caddr len hash ; first char + count 571 current @ \ -- caddr len hash wid ; get wid = voc-cfa 572 dup >#threads @ 1- rot and cells \ mask for #threads 573 swap >threads + \ -- caddr len thread ; form thread addr 574 dup @ , \ lay old thread ; thread is in RAM 575 here swap ! \ -- caddr len ; link this word - here is new NFA 576 \ lay count + string 577 here last ! \ NFA of latest word 578 swap 1- swap 1+ \ -- caddr' len' ; step back to count byte 579 immheader @ \ see if word must be immediate 580 if $80 else $C0 endif \ -- caddr len mask 581 2 pick bor! \ set bits 7 and 6 in count byte 582 immheader off 583 bounds ?do i w@ w, 2 +loop \ STM32 Flash has to be programmed in 16 bit units 584 align \ xt must be even 585 ; 586 587 : dataAddr, \ flag -- 588 \ +G Lay the data address for a defining word where the flag is 589 \ +* true for compiling to Flash. 590 if dp @ cell + else rp @ endif 591 , 592 ; 593 external 594 595 (( 596 : IMMEDIATE \ -- 597 \ *G Mark the last defined word as *\fo{IMMEDIATE}. Immediate 598 \ ** words will execute whenever encountered regardless of 599 \ ** *\fo{STATE}. 600 $40 last @ bbic! \ bit 6 := 0 601 ; 602 )) 603 604 605 \ --------------------- 606 \ *S String compilation 607 \ --------------------- 608 609 internal 610 : (C") \ -- c-addr 611 \ *G The run-time action for *\fo{C"} which returns the address of and 612 \ ** steps over a counted string. 613 \ ** INTERNAL. 614 (") 615 ; 616 617 : (S") \ -- c-addr u 618 \ *G The run-time action for *\fo{S"} which returns the address and 619 \ ** length of and steps over a string. 620 \ ** INTERNAL. 621 (") count 622 ; 623 624 : (ABORT") \ i*x x1 -- | i*x 625 \ *G The run time action of *\fo{ABORT"}. 626 \ ** INTERNAL. 627 (") swap if 628 'AbortText ! -2 throw 629 else 630 drop 631 then 632 ; 633 634 : (.") \ -- 635 \ *G The run-time action of *\fo{."}. 636 \ ** INTERNAL. 637 (") count type 638 ; 639 external 640 641 642 \ ============================ 643 \ *S ANS words CATCH and THROW 644 \ ============================ 645 \ *P *\fo{CATCH} and *\fo{THROW} form the basis of all Forth error 646 \ ** handling. The following description of *\fo{CATCH} and 647 \ ** *\fo{THROW} originates with Mitch Bradley and is taken from 648 \ ** an ANS Forth standard draft. 649 650 \ *P *\fo{CATCH} and *\fo{THROW} provide a reliable mechanism for 651 \ ** handling exceptions, without having to propagate exception 652 \ ** flags through multiple levels of word nesting. It is similar 653 \ ** in spirit to the "non-local return" mechanisms of many other 654 \ ** languages, such as C's *\b{setjmp()} and *\b{longjmp()}, 655 \ ** and LISP's *\b{CATCH} and *\b{THROW}. In the Forth context, 656 \ ** *\fo{THROW} may be described as a "multi-level EXIT", with 657 \ ** *\fo{CATCH} marking a location to which a *\fo{THROW} may return. 658 659 \ *P Several similar Forth "multi-level EXIT" exception-handling 660 \ ** schemes have been described and used in past years. It is not 661 \ ** possible to implement such a scheme using only standard words 662 \ ** (other than *\fo{CATCH} and *\fo{THROW}), because there is no 663 \ ** portable way to "unwind" the return stack to a predetermined 664 \ ** place. 665 666 \ *P *\fo{THROW} also provides a convenient implementation technique 667 \ ** for the standard words *\fo{ABORT} and *\fo{ABORT"}, allowing 668 \ ** an application to define, through the use of *\fo{CATCH}, the 669 \ ** behavior in the event of a system abort. 670 671 \ ============== 672 \ *N Example use 673 \ ============== 674 \ *P If *\fo{THROW} is executed with a non zero argument, the 675 \ ** effect is as if the corresponding *\fo{CATCH} had returned it. 676 \ ** In that case, the stack depth is the same as it was just 677 \ ** before *\fo{CATCH} began execution. 678 \ ** The values of the i*x stack arguments could have been modified 679 \ ** arbitrarily during the execution of xt. In general, nothing useful 680 \ ** may be done with those stack items, but since their number is known 681 \ ** (because the stack depth is deterministic), the application may 682 \ ** *\fo{DROP} them to return to a predictable stack state. 683 684 \ *P Typical use: 685 \ *E : could-fail \ -- char 686 \ ** KEY DUP [CHAR] Q = 687 \ ** IF 1 THROW THEN 688 \ ** ; 689 \ ** 690 \ ** : do-it \ a b -- c 691 \ ** 2DROP could-fail 692 \ ** ; 693 \ ** 694 \ ** : try-it \ -- 695 \ ** 1 2 ['] do-it CATCH IF 696 \ ** ( -- x1 x2 ) 2DROP ." There was an exception" CR 697 \ ** ELSE 698 \ ** ." The character was " EMIT CR 699 \ ** THEN 700 \ ** ; 701 \ ** 702 \ ** : retry-it \ -- 703 \ ** BEGIN 704 \ ** 1 2 ['] do-it CATCH 705 \ ** WHILE 706 \ ** ( -- x1 x2 ) 2DROP ." Exception, keep trying" CR 707 \ ** REPEAT ( char ) 708 \ ** ." The character was " EMIT CR 709 \ ** ; 710 711 \ ========== 712 \ *N Gotchas 713 \ ========== 714 \ *P If a *\fo{THROW} is performed without a *\fo{CATCH} in place, 715 \ ** the system will/may crash. As the current exception frame 716 \ ** is pointed to by the *\fo{USER} variable *\fo{HANDLER}, 717 \ ** each task and interrupt handler will need a *\fo{CATCH} if 718 \ ** *\fo{THROW} is used inside it. 719 720 \ *P You can no longer use *\fo{ABORT} as a way of resetting the 721 \ ** data stack and calling *\fo{QUIT}. *\fo{ABORT} is now defined 722 \ ** as *\fo{-1 THROW}. 723 724 \ ============= 725 \ *N User words 726 \ ============= 727 728 : CATCH \ i*x xt -- j*x 0|i*x n 729 \ *G Execute the code at XT with an exception frame protecting it. 730 \ ** *\fo{CATCH} returns a 0 if no error has occurred, otherwise it 731 \ ** returns the throw-code passed to the last *\fo{THROW}. 732 sp@ >r \ save PSP 733 lp@ >r \ save LP 734 handler @ >r \ and last handler 735 rp@ handler ! \ set new handler 736 execute \ this gets back if there's no THROW 737 r> handler ! \ restore previous handler 738 r> drop \ discard saved LP 739 r> drop \ discard saved PSP 740 0 \ good exit = 0 741 ; 742 743 : THROW \ k*x n -- k*x|i*x n 744 \ *G Throw a non-zero exception code n back to the last *\fo{CATCH} 745 \ ** call. If n is 0, no action is taken except to *\fo{DROP} n. 746 ?dup 0= if exit then \ zero = no throw 747 handler @ rp! \ restore last RSP 748 r> handler ! \ restore prev handler 749 r> lp! \ restore LP 750 r> swap >r \ n > RS 751 sp! drop r> \ restore DS 752 \ Returns to caller of CATCH 753 ; 754 755 : ?throw \ flag throw-code -- ; SFP017 756 \ *G Perform a *\fo{THROW} of value throw-code if flag is non-zero, 757 \ ** otherwise do nothing except discard flag and throw-code. 758 swap 759 if throw else drop endif 760 ; 761 762 : ABORT" \ Comp: "ccc<quote>" -- ; Run: i*x x1 -- | i*x ; R: j*x -- | j*x 763 \ *G If x1 is non-zero at run-time, store the address of the 764 \ ** following counted string in *\fo{USER} variable *\fo{'ABORTTEXT}, 765 \ ** and perform *\fo{-2 THROW}. The text interpreter in *\fo{QUIT} 766 \ ** will (if reached) display the text. 767 ?comp compile (abort") ", 768 ; IMMEDIATE 769 770 771 \ ******************************** 772 \ *S Formatted and unformatted i/o 773 \ ******************************** 774 775 \ ======================= 776 \ *N Setting number bases 777 \ ======================= 778 779 : HEX \ -- 780 \ *G Change current radix to base 16. 781 #16 base ! 782 ; 783 784 : DECIMAL \ -- 785 \ *G Change current radix to base 10. 786 #10 base ! 787 ; 788 789 compiler 790 : binary ( -- ) 2 base ! ; 791 target 792 793 \ ================= 794 \ *N Numeric output 795 \ ================= 796 797 : HOLD \ char -- 798 \ *G Insert the ASCII 'char' value into the pictured numeric output 799 \ ** string currently being assembled. 800 -1 hld +! hld @ c! 801 ; 802 803 (( 804 : SIGN \ n -- 805 \ *G Insert the ascii 'minus' symbol into the numeric output string if 806 \ ** 'n' is negative. 807 0< if [char] - hold then 808 ; 809 )) 810 811 : # \ ud1 -- ud2 812 ( *G Given a double number on the stack this will add the next digit to ) 813 ( ** the pictured numeric output buffer and return the next double ) 814 ( ** number to work with. PLEASE NOTE THAT THE NUMERIC OP STRING IS ) 815 \ ** BUILT FROM RIGHT (l.s. ddigit) to LEFT (m.s. digit). 816 base @ mu/mod rot 9 over < 817 if 7 + then 818 [char] 0 + hold 819 ; 820 821 : #S \ ud1 -- ud2 822 \ *G Keep performing *\fo{#} until all digits are generated. 823 begin # 2dup or 0= until 824 ; 825 826 : <# \ -- 827 ( *G Begin definition of a new numeric output string buffer. ) 828 pad hld ! 829 ; 830 831 : #> \ xd -- c-addr u 832 \ *G Terminate defnition of a numeric output string. Return the 833 \ ** address and length of the ASCII string. 834 2drop hld @ pad over - ; 835 836 (( 837 : -TRAILING \ c-addr u1 -- c-addr u2 838 \ *G Modify a string address/length pair to ignore any trailing spaces. 839 dup 0 ?do 840 2dup + 1- c@ bl <> ?leave 841 1- 842 loop 843 ; 844 )) 845 846 : D.R \ d n -- 847 \ *G Output the double number 'd' using current radix, right justified 848 \ ** to 'n' characters. Padding is inserted using spaces on the left 849 \ ** side. 850 >r swap over dabs <# 851 #s rot 0< 852 if [char] - hold then 853 #> 854 \ >r swap over dabs <# #s rot sign #> 855 r> over - spaces type 856 ; 857 858 : D. \ d -- 859 \ *G Output the double number 'd' without padding. 860 0 d.r space 861 ; 862 863 : . \ n -- 864 \ *G Output the cell signed value 'n' without justification. 865 s>d d. 866 ; 867 868 : U. \ u -- 869 \ *G As with . but treat as unsigned. 870 0 d. 871 ; 872 873 (( 874 : U.R \ u n -- 875 \ *G As with D.R but uses a single-unsigned cell value. 876 0 swap d.r 877 ; 878 )) 879 880 : .R \ n1 n2 -- 881 \ *G As *\fo{D.R} but uses a single-signed cell value. 882 >r s>d r> d.r 883 ; 884 885 886 \ ================ 887 \ *N Numeric input 888 \ ================ 889 890 : +DIGIT \ d1 n -- d2 ; accumulates digit into double accumulator 891 \ *G Multiply d1 by the current radix and add n to it. 892 \ ** INTERNAL. 893 swap base @ um* drop \ accumulate into double 894 rot base @ um* d+ 895 ( 1 #d +! ) dpl @ 1+ \ incr. #digits, double? 896 if 1 dpl +! then \ yes, incr. after d.p. 897 ; 898 899 : >NUMBER \ ud1 c-addr1 u1 -- ud2 c-addr2 u2 ; convert all until non-digits 900 \ *G Accumulate digits from string c-addr1/u2 into double number ud1 901 \ ** to produce ud2 until the first non-convertible character is found. 902 \ ** c-addr2/u2 represents the remaining string with c-addr2 pointing 903 \ ** the non-convertible character. The number base for conversion is 904 \ ** defined by the contents of *\fo{USER} variable *\fo{BASE}. 905 \ ** *\fo{>NUMBER} is case insensitive. 906 dup 0 ?do 907 over c@ upc base @ digit 0= ?leave \ convert char to digit, get out if failed 908 -rot 2>r +digit 2r> \ accumulate digit 909 1 /string \ bump address, decr char count 910 loop 911 ; 912 913 internal 914 915 : (INTEGER?) \ c-addr u -- d/n/- 2/1/0 916 \ *G The guts of *\fo{INTEGER?} but without the base override handling. 917 \ ** See *\fo{INTEGER?} 918 \ ** INTERNAL. 919 -1 dpl ! over c@ [char] - = dup >r 920 if 1 /string endif 921 dup 1 < if 2drop 0 r> drop exit endif 922 0 0 2swap begin \ -- d caddr len 923 >number dup 924 while 925 1 /string case over 1- c@ 926 [char] : of endof \ ignore 927 [char] . of dpl off endof \ . for double numbers 928 drop 2drop 2drop 0 r> drop exit 929 endcase 930 repeat 931 2drop 932 \ r> ?dnegate 933 r> if dnegate then 934 dpl @ 0< 935 if drop 1 else 2 endif 936 ; 937 938 : Check-Prefix \ addr len -- addr' len' 939 \ *G If any *\fo{BASE} override prefices or suffices are used 940 \ ** in the input string, set *\fo{BASE} accordingly and return 941 \ ** the string without the override characters. 942 \ ** INTERNAL. 943 Case over c@ \ get possible prefix char 944 [char] $ Of 1 /string hex Endof \ $ for HEX 945 [char] # Of 1 /string decimal Endof \ # for DECIMAL 946 [char] % Of 1 /string binary Endof \ % for BINARY 947 EndCase 948 ; 949 950 external 951 952 (( 953 : number? \ $addr -- n 1 | d 2 | 0 954 \ *G Attempt to convert the counted string at 'addr' to an integer. 955 \ ** The return result is either 0 for failed, 1 for a single-cell 956 \ ** return result followed by that cell, or 2 for a double return. 957 \ ** The ASCII number string supplied can also contain implicit radix 958 \ ** over-rides. A leading $ enforces hexadecimal, a leading # enforces 959 \ ** decimal and a leading % enforces binary. 960 count dup if \ if something to do 961 2dup upper \ convert to upper case 962 base @ >r \ preserve current base 963 check-prefix (integer?) \ check prefix, convert to number 964 r> base ! \ restore base 965 Else 966 2drop ( #l off ) 0 967 Endif 968 ; 969 )) 970 : integer? \ $addr -- n 1 | d 2 | 0 971 \ *G Attempt to convert the counted string at 'addr' to an integer. 972 \ ** The return result is either 0 for failed, 1 for a single-cell 973 \ ** return result followed by that cell, or 2 for a double return. 974 \ ** The ASCII number string supplied can also contain implicit radix 975 \ ** over-rides. A leading $ enforces hexadecimal, a leading # enforces 976 \ ** decimal and a leading % enforces binary. 977 count dup if \ if something to do 978 2dup upper \ convert to upper case 979 base @ >r \ preserve current base 980 check-prefix (integer?) \ check prefix, convert to number 981 r> base ! \ restore base 982 Else 983 2drop ( #l off ) 0 984 Endif 985 ; 986 987 defer number? \ $addr -- n 1 | d 2 | 0 988 assign integer? to-do number? 989 \ ========================== 990 \ *S String input and output 991 \ ========================== 992 993 internal 994 995 : BS \ -- ; destructive backspace 996 \ *G Perform a destructive backspace by issuing ASCII characters 997 \ ** 8, 20h, 8. If *\fo{OUT} is non-zero at the start, it is decremented 998 \ ** by one regardless of the actions of the device driver. 999 \ ** INTERNAL. 1000 out @ ?dup if 1001 bsout emit space bsout emit 1002 1- out ! 1003 then 1004 ; 1005 1006 : ?BS \ pos -- pos' step ; perform BS if pos non-zero 1007 \ *G If pos is non-zero and *\fo{ECHOING} is set, perform *\fo{BS} 1008 \ ** and return the size of the step, 0 or -1. 1009 \ ** INTERNAL. 1010 dup 0<> echoing @ 0<> and if \ pos non-zero and echo 1011 bs 1- -1 \ perform backspace 1012 else 1013 0 \ no 1014 then 1015 ; 1016 1017 : SAVE-CH \ char addr -- ; save as required 1018 \ *G Save char at addr, and output the character if 1019 \ ** *\fo{ECHOING} is set. 1020 \ ** INTERNAL. 1021 over swap c! \ stash character 1022 echoing @ \ echo it? 1023 if emit else drop then \ process accordingly 1024 ; 1025 1026 external 1027 1028 : ." \ "ccc<quote>" -- 1029 \ *G Output the text upto the closing double-quotes character. 1030 \ ** Use *\fo{.( <text>)} when interpreting. 1031 ['] (.") compile, ", 1032 ; 1033 IMMEDIATE 1034 1035 : $. \ c-addr -- ; display counted string 1036 \ *G Output a counted-string to the output device. 1037 count type 1038 ; 1039 1040 : ACCEPT \ c-addr +n1 -- +n2 ; read up to LEN chars into ADDR 1041 \ *G Read a string of maximum size n1 characters to the buffer at 1042 \ ** c-addr, returning n2 the number of characters actually read. Input 1043 \ ** may be terminated by CR. The action may be input device specific. 1044 \ ** If *\fo{ECHOING} is non-zero, characters are echoed. 1045 \ ** If *\fo{XON/XOFF} is non-zero, an XON character is sent at the 1046 \ ** start and an XOFF character is sent at the the end. 1047 dup 0= \ check for pathological case 1048 if nip exit then 1049 xon/xoff @ if xon emit then \ enable server 1050 0 -rot bounds \ form address limits 1051 ?do 1052 case key \ get character 1053 bsin of ?bs endof \ BS 1054 atab of bl i save-ch 1+ 1 endof \ TAB, convert to space 1055 \ alf of bl i save-ch 1+ 1 endof \ LF, convert to space 1056 alf of 0 endof \ LF, ignore 1057 acr of bl i save-ch leave endof \ CR 1058 ffeed of bl i save-ch leave endof \ FF, treat like CR 1059 delin of ?bs endof \ DEL 1060 i save-ch 1+ 1 0 \ stash char, echo it? 1061 endcase 1062 +loop \ round again 1063 xon/xoff @ if xoff emit then \ disable server 1064 ; 1065 1066 1067 \ *********************** 1068 \ *S Source input control 1069 \ *********************** 1070 1071 internal 1072 variable <source> 1073 1074 : SOURCE-ID \ -- n ; indicates input source 1075 \ *G Returns an indicator of which device is generating 1076 \ ** source input. See the ANS specification for more details. 1077 <source> @ 1078 ; 1079 1080 compiler 1081 : SOURCE-ID ( -- n ) <source> @ ; 1082 : TO-SOURCE ( c-addr u -- ) #tib ! 'tib ! ; 1083 target 1084 1085 internal 1086 : SOURCE \ -- c-addr u 1087 \ *G Returns the address and length of the current terminal input 1088 \ ** buffer. 1089 \ ** INTERNAL 1090 'tib @ #tib @ 1091 ; 1092 external 1093 1094 : QUERY \ -- ; fetch line into TIB 1095 ( *G Reset the input source specification to the console and accept a ) 1096 ( ** line of text into the input buffer. ) 1097 0 <source> ! \ mark source as keyboard 1098 'tib @ tib-len 1- accept #tib ! \ "tib-len 1-" was #80 1099 >in off 1100 ; 1101 1102 1103 \ ================ 1104 \ *S Text scanning 1105 \ ================ 1106 1107 : PARSE \ char "ccc<char>" -- c-addr u 1108 \ *G Parse the next token from the terminal input buffer using 1109 \ ** <char> as the delimiter. The next token is returned as a 1110 \ ** *\fo{c-addr/u} string description. Note that *\fo{PARSE} does 1111 \ ** not skip leading delimiters. If you need to skip leading 1112 \ ** delimiters, use *\fo{PARSE-WORD} instead. 1113 >r 1114 source >in @ /string \ remainder of input is substring 1115 over swap r> scan \ look for char 1116 >r over - \ subtract addresses to get length 1117 dup r> 0<> - \ if string found then bump >IN past char 1118 >in +! \ update >IN to reflect parsed text 1119 ; 1120 1121 internal 1122 : PARSE-WORD \ char -- c-addr u ; find token, skip leading chars 1123 \ *G An alternative to *\fo{WORD} below. The return is a 1124 \ ** *\i{c-addr/u} pair rather than a counted string and no copy 1125 \ ** has occured, i.e. the contents of *\fo{HERE} are unaffected. 1126 \ ** Because no intermediate global buffers are used *\fo{PARSE-WORD} 1127 \ ** is more reliable than *\fo{WORD} for text scanning in multi-threaded 1128 \ ** applications. 1129 \ ** INTERNAL. 1130 >r source tuck >in @ /string 1131 r@ skip over swap r> scan 1132 >r over - rot r> dup 0<> + - >in ! 1133 ; 1134 external 1135 1136 : WORD \ char "<chars>ccc<char>" -- c-addr 1137 \ *G Similar behaviour to the ANS word *\fo{PARSE} but the returned 1138 \ ** string is described as a counted string. 1139 parse-word rp @ place rp @ 1140 ; 1141 1142 1143 \ ---------------- 1144 \ *S Miscellaneous 1145 \ ---------------- 1146 1147 internal 1148 1149 : HALT? \ -- flag 1150 \ *G Used in listed displays. This word will check the keyboard for a 1151 \ ** 'pause' key <space>, if the key is pressed it will then wait for 1152 \ ** a continue key or an abort key. The return flag is TRUE if abort 1153 \ ** is requested. Line Feed (LF, ASCII 10) characters are ignored. 1154 key? dup 0= \ key not pressed? 1155 if exit endif 1156 key bl = if \ space? 1157 drop \ chuck previous flag 1158 key bl <> \ get second char 1159 then 1160 ; 1161 1162 origin [if] \ only if ORIGIN is non-zero 1163 : origin- \ addr -- addr' 1164 \ +G If addr is non-zero, subtract the start address of the first 1165 \ +* defined CDATA section. 1166 \ +* This word is only compiled if the start address of the first 1167 \ +* defined CDATA section is non-zero. 1168 \ +* INTERNAL. 1169 dup if origin - then \ normalize if non-zero 1170 ; 1171 1172 compiler 1173 : origin+ \ addr -- addr' ; denormalise NFA again 1174 \ +G If addr is non-zero, add the start address of the first 1175 \ +* defined CDATA section. 1176 \ +* This word is only compiled if the start address of the first 1177 \ +* defined CDATA section is non-zero. 1178 \ +* INTERNAL. 1179 dup if origin + then \ normalize if non-zero 1180 ; 1181 target 1182 [else] 1183 compiler \ treat these as immediate noops 1184 : origin- ; 1185 : origin+ ; 1186 target 1187 [then] 1188 1189 : nfa-buff \ -- addr+len addr ; make a buffer for holding NFAs 1190 \ +G Form a temporary buffer for holding NFAs. A factor for 1191 \ +* *\fo{WORDS}. 1192 \ +* INTERNAL. 1193 pad \ buffer 1194 context @ >#threads @ cells \ length 1195 bounds 1196 ; 1197 1198 : MAX-NFA \ -- addr c-addr ; returns addr and top nfa 1199 \ +G Return the thread address and NFA of the highest word 1200 \ +* in the NFA buffer. A factor for *\fo{WORDS}. 1201 \ +* INTERNAL. 1202 0 0 \ clear result 1203 nfa-buff do 1204 i @ over u> if \ if greater 1205 2drop i i @ \ replace current set 1206 then 1207 cell +loop \ step on 1208 origin+ \ de-normalize 1209 ; 1210 1211 : COPY-THREADS \ addr -- 1212 \ +G Copy the threads of the *\fo{CONTEXT} wordlist to a 1213 \ +* temporary NFA buffer for manipulation. A factor for 1214 \ +* *\fo{WORDS}. 1215 \ +* INTERNAL. 1216 context @ >threads \ source 1217 nfa-buff do \ destination/len 1218 dup @ origin- i ! 1219 cell+ 1220 cell +loop \ copy and normalise 1221 drop \ discard source addr 1222 ; 1223 1224 external 1225 1226 : WORDS \ -- 1227 \ *G Display the names of all definitions in the wordlist at the 1228 \ ** top of the search-order. 1229 cr ." WORDS " 1230 cr \ set up 1231 copy-threads \ copy out & normalize 1232 begin 1233 max-nfa dup \ while still one left 1234 halt? 0= and \ and no stop command 1235 while 1236 out @ c/l > if cr then \ new line if needed 1237 dup .name \ show name 1238 n>link @ origin- swap ! \ find next 1239 repeat 1240 2drop 1241 ; 1242 1243 : MOVE \ addr1 addr2 u -- ; intelligent move 1244 \ *G An intelligent memory move, chooses between *\fo{CMOVE} and 1245 \ ** *\fo{CMOVE>} at runtime to avoid memory overlap problems. 1246 \ ** Note that as ROM PowerForth characters are 8 bit, there is 1247 \ ** an implicit connection between a byte and a character. 1248 >r 2dup swap - r@ u< if \ overlap if dest-src<len ; MPE011 1249 r> cmove> \ move down 1250 else 1251 r> cmove \ move up 1252 then 1253 ; 1254 1255 : DEPTH \ ??? -- +n 1256 \ *G Return the number of items on the data stack. 1257 s0 @ sp@ - cell - cell / 1258 ; 1259 1260 1261 \ ------------------- 1262 \ *S Wordlist control 1263 \ ------------------- 1264 1265 \ Cortex 1266 asmcode 1267 here is-action-of vocabulary \ -- 1268 \ *G The runtime action of a *\fo{VOCABULARY}. 1269 mov r0, lr \ point to data address 1270 sub .s r0, r0, # 1 \ remove Thumb bit 1271 ldr r2, [ r0, # 0 ] \ data address 1272 ldr r2, [ r2, # 0 ] \ get wid 1273 ldr r3, ^context \ address of context 1274 str r2, [ r3, # 0 ] \ store WID at CONTEXT 1275 pop { pc } 1276 end-code 1277 align l: ^context 1278 context , 1279 1280 (( \ MSP430 1281 asmcode 1282 here is-action-of vocabulary \ -- 1283 \ *G The runtime action of a *\fo{VOCABULARY}. 1284 pop r14 \ get address of address 1285 mov @r14 r14 \ get address 1286 mov @r14 & context \ set contents 1287 ret 1288 end-code 1289 )) 1290 1291 1292 \ --------------------- 1293 \ *S Control structures 1294 \ --------------------- 1295 1296 internal 1297 : ?PAIRS \ x1 x2 -- 1298 \ *G If x1<>x2, issue and error. 1299 \ ** Used for on-target compile-time error checking. 1300 \ ** INTERNAL. 1301 <> #-22 ?throw 1302 ; 1303 1304 : !CSP \ x -- 1305 \ *G Save the stack pointer in *\fo{CSP}. 1306 \ ** Used for on-target compile-time error checking. 1307 \ ** INTERNAL. 1308 sp@ csp ! 1309 ; 1310 1311 : ?CSP \ -- 1312 \ *G Issue an error if the stack pointer is not the 1313 \ ** same as the value previously stored in CSP. 1314 \ ** Used for on-target compile-time error checking. 1315 \ ** INTERNAL. 1316 sp@ csp @ <> #-22 ?throw 1317 ; 1318 1319 : ?COMP \ -- 1320 \ *G Error if not in compile state. 1321 \ ** INTERNAL. 1322 state @ 0= #-14 ?throw 1323 ; 1324 1325 : ?EXEC \ -- 1326 \ *G Error if not interpreting. 1327 \ ** INTERNAL. 1328 state @ #-403 ?throw 1329 ; 1330 external 1331 1332 : DO \ C: -- do-sys ; Run: n1|u1 n2|u2 -- ; R: -- loop-sys 1333 \ *G Begin a *\fo{DO ... LOOP} construct. Takes the end-value and 1334 \ ** start-value from the data-stack. 1335 ?comp c_do 3 1336 ; IMMEDIATE 1337 1338 : ?DO \ C: -- do-sys ; Run: n1|u1 n2|u2 -- ; R: -- | loop-sys 1339 \ *G Compile a *\fo{DO} which will only begin loop execution if the 1340 \ ** loop parameters are not the same. Thus *\fo{0 0 ?DO ... LOOP} 1341 \ ** will not execute the contents of the loop. 1342 ?comp c_?do 3 1343 ; IMMEDIATE 1344 1345 : LOOP \ C: do-sys -- ; Run: -- ; R: loop-sys1 -- | loop-sys2 1346 \ *G The closing statement of a *\fo{DO..LOOP} construct. 1347 \ ** Increments the index and terminates when the index crosses 1348 \ ** the limit. 1349 ?comp 3 ?pairs c_loop 1350 ; IMMEDIATE 1351 1352 : +LOOP \ C: do-sys -- ; Run: n -- ; R: loop-sys1 -- | loop-sys2 1353 \ *G As with *\fo{LOOP} except that you specify the increment on 1354 \ ** the data-stack. 1355 ?comp 3 ?pairs c_+loop 1356 ; IMMEDIATE 1357 1358 : BEGIN \ C: -- dest ; Run: -- 1359 \ *G Mark the start of a structure of the form: 1360 \ *C BEGIN..[while]..UNTIL / AGAIN / [REPEAT] 1361 ?comp c_mrk_branch< 1362 ; IMMEDIATE 1363 1364 : AGAIN \ C: dest -- ; Run: -- 1365 \ *G The end of a *\fo{BEGIN..AGAIN} construct which specifies 1366 \ ** an infinite loop. ) 1367 ?comp c_branch< 1368 ; IMMEDIATE 1369 1370 : UNTIL \ C: dest -- ; Run: x -- 1371 \ *G Compile code into definition which will jump back to the 1372 \ ** matching *\fo{BEGIN} if the supplied condition flag is 1373 \ ** Zero/FALSE. 1374 ?comp c_?branch< 1375 ; IMMEDIATE 1376 1377 : WHILE \ C: dest -- orig dest ; Run: x -- 1378 \ *G Separate the condition test from the loop code in a 1379 \ ** *\fo{BEGIN..WHILE..REPEAT} block. 1380 ?comp c_?branch> swap 1381 ; IMMEDIATE 1382 1383 : REPEAT \ C: orig dest -- ; Run: -- 1384 \ *G Loop back to the conditional dest code in a 1385 \ ** *\fo{BEGIN..WHILE..REPEAT} construct. ) 1386 ?comp c_branch< >c_res_branch \ SFP003 1387 ; IMMEDIATE 1388 1389 : IF \ C: -- orig ; Run: x -- 1390 \ *G Mark the start of an *\fo{IF..[ELSE]..THEN} conditional 1391 \ ** block. 1392 ?comp c_?branch> 1393 ; IMMEDIATE 1394 1395 : THEN \ C: orig -- ; Run: -- 1396 \ *G Mark the end of an *\fo{IF..THEN} or *\fo{IF..ELSE..THEN} 1397 \ ** conditional construct. 1398 ?comp >c_res_branch 1399 ; IMMEDIATE 1400 1401 : ELSE \ C: orig1 -- orig2 ; Run: -- 1402 \ *G Begin the failure condition code for an *\fo{IF}. 1403 ?comp c_branch> swap >c_res_branch 1404 ; IMMEDIATE 1405 1406 : CASE \ C: -- case-sys ; Run: -- 1407 \ *G Begin a *\fo{CASE..ENDCASE} construct. Similar to C's 1408 \ ** *\b{switch}. 1409 ?comp csp @ c_case !csp 4 1410 ; IMMEDIATE 1411 1412 : OF \ C: -- of-sys ; Run: x1 x2 -- | x1 1413 \ *G Begin conditional block for *\fo{CASE}, executed when the 1414 \ ** switch value is equal to the X2 value placed in TOS. 1415 4 ?pairs c_of 5 1416 ; IMMEDIATE 1417 1418 : ?OF \ C: -- of-sys ; Run: flag -- 1419 \ *G Begin conditional block for *\fo{CASE}, executed when the flag 1420 \ ** is true. 1421 4 ?pairs c_?of 5 1422 ; IMMEDIATE 1423 1424 : ENDOF \ C: case-sys1 of-sys -- case-sys2 ; Run: -- 1425 \ *G Mark the end of an OF conditional block within a *\fo{CASE} 1426 \ ** construct. Compile a jump past the *\fo{ENDCASE} marker at 1427 \ ** the end of the construct. 1428 5 ?pairs c_endof 4 1429 ; IMMEDIATE 1430 1431 : ENDCASE \ C: case-sys -- ; Run: x -- 1432 \ *G Terminate a *\fo{CASE..ENDCASE} construct. *\fo{DROP}s the 1433 \ ** switch value from the stack. 1434 4 ?pairs c_endcase csp ! 1435 ; IMMEDIATE 1436 1437 : NEXTCASE \ C: case-sys -- ; Run: x -- 1438 \ *G Terminate a *\fo{CASE..NEXTCASE} construct. *\fo{DROP}s the 1439 \ ** switch value from the stack and compiles a branch back to the 1440 \ ** top of the loop at *\fo{CASE}. 1441 4 ?pairs c_nextcase csp ! 1442 ; IMMEDIATE 1443 1444 : RECURSE \ Comp: -- 1445 \ *G Compile a recursive call to the colon definition containing 1446 \ ** *\fo{RECURSE} itself. Do not use *\fo{RECURSE} between 1447 \ ** *\fo{DOES>} and *\fo{;}. Used in the form: 1448 \ *C : foo ... recurse ... ; 1449 \ *P to compile a reference to *\fo{FOO} from inside *\fo{FOO}. 1450 Last @ name> compile, 1451 ; IMMEDIATE 1452 1453 1454 \ ********************************** 1455 \ *S Target interpreter and compiler 1456 \ ********************************** 1457 1458 internal 1459 : ?STACK \ -- 1460 \ *G Error if stack pointer out of range. 1461 \ ** INTERNAL. 1462 sp@ s0 @ u> #-4 ?throw 1463 ; 1464 1465 : ?UNDEF \ x -- 1466 \ *G Word not defined error if x=0. 1467 \ ** INTERNAL. 1468 0= #-13 ?throw 1469 ; 1470 external 1471 1472 : POSTPONE \ Comp: "<spaces>name" -- 1473 \ *G Compile a reference to another word. *\fo{POSTPONE} can handle 1474 \ ** compilation of *\fo{IMMEDIATE} words which would otherwise be 1475 \ ** executed during compilation. 1476 bl word find dup ?undef \ it is a name 1477 -1 = if \ if non-immediate 1478 [compile] literal ['] compile, \ lay "lit xt compile," 1479 then 1480 compile, \ immediate word will be compiled now 1481 ; IMMEDIATE 1482 1483 : S" \ Comp: "ccc<quote>" -- ; Run: -- c-addr u 1484 \ *G Describe a string. Text is taken up to the next double-quote 1485 \ ** character. The address and length of the string are returned. 1486 state @ if 1487 compile (s") ", 1488 else 1489 [char] " parse pad place pad count 1490 then 1491 ; IMMEDIATE 1492 1493 : C" \ Comp: "ccc<quote>" -- ; Run: -- c-addr 1494 \ *G As *\fo{S"} except the address of a counted string is returned. 1495 state @ if 1496 compile (c") ", 1497 else 1498 [char] " parse pad place pad 1499 then 1500 ; 1501 IMMEDIATE 1502 1503 : LITERAL \ Comp: x -- ; Run: -- x 1504 \ *G Compile a literal into the current definition. Usually used 1505 \ ** in the form *\fo{[ <expression ] LITERAL} inside a colon 1506 \ ** definition. Note that *\fo{LITERAL} is *\fo{IMMEDIATE}. 1507 c_lit 1508 ; 1509 IMMEDIATE 1510 1511 : CHAR \ "<spaces>name" -- char 1512 ( *G Return the first character of the next token in the input stream. ) 1513 ( ** Usually used to avoid magic numbers in the source code. ) 1514 bl word 1+ c@ 1515 ; 1516 1517 : [CHAR] \ Comp: "<spaces>name" -- ; Run: -- char 1518 ( *G Compile the first character of the next token in the input stream ) 1519 ( ** as a literal. Usually used to avoid magic numbers in the source ) 1520 ( ** code. ) 1521 ?comp char [compile] literal 1522 ; 1523 IMMEDIATE 1524 1525 : [ \ -- 1526 \ *G Switch compiler into interpreter state. 1527 state off 1528 ; 1529 IMMEDIATE 1530 1531 : ] \ -- 1532 \ *G Switch compiler into compilation state. 1533 state on 1534 ; 1535 1536 : ' \ "<spaces>name" -- xt 1537 \ *G Find the xt of the next word in the input stream. An error occurs 1538 \ ** if the xt cannot be found. 1539 bl word find ?undef 1540 ; 1541 1542 : ['] \ Comp: "<spaces>name" -- ; Run: -- xt 1543 \ *G Find the xt of the next word in the input stream, and compile it 1544 \ ** as a literal. An error occurs if the xt cannot be found. 1545 ' [compile] literal 1546 ; 1547 IMMEDIATE 1548 1549 : [COMPILE] \ "<spaces>name" -- 1550 \ *G Compile the next word in the input stream. *\fo{[COMPILE]} 1551 \ ** ignores the *\fo{IMMEDIATE} state of the word. Its operation 1552 \ ** is mostly superceded by *\fo{POSTPONE}. 1553 ' compile, 1554 ; 1555 IMMEDIATE 1556 1557 : ( \ "ccc<paren>" -- 1558 \ *G Begin an inline comment. All text upto the closing bracket is 1559 \ ** ignored. 1560 [char] ) word drop 1561 ; 1562 IMMEDIATE 1563 1564 : \ \ "ccc<eol>" -- 1565 \ *G Begin a single-line comment. All text up to the end of the line is 1566 \ ** ignored. 1567 0 word drop \ use variable length line 1568 ; 1569 IMMEDIATE 1570 1571 : ", \ "ccc<quote>" -- 1572 \ *G Parse text up to the closing quote and compile into the 1573 \ ** dictionary at *\fo{HERE} as a counted string. The end of the 1574 \ ** string is aligned. 1575 [char] " word dup c@ 1+ \ addr len 1576 bounds ?do i w@ w, 2 +loop \ STM32 Flash has to be programmed in 16 bit units 1577 align 1578 ; 1579 1580 internal 1581 : (TO-DO) \ -- ; R: xt -- a-addr' 1582 \ *G The run-time action of *\fo{IS}. It is followed by the 1583 \ ** data addres of the *\fo{DEFER}red word at which the xt is stored. 1584 \ ** INTERNAL. 1585 r> dup cell+ aligned >r 1586 @ ! 1587 ; 1588 external 1589 1590 : IS \ "<spaces>name" -- 1591 \ *G The second part of the *\fo{ASSIGN xxx TO-DO yyy} construct. 1592 \ ** This word will assign the given XT to be the action of a 1593 \ ** *\fo{DEFER}ed word which is named in the input stream. 1594 ' >body state @ if 1595 compile (to-do) , 1596 else 1597 ! 1598 then 1599 ; 1600 IMMEDIATE 1601 1602 : exit \ R: nest-sys -- ; exit current definition 1603 \ *G Compile code into the current definition to cause a definition to 1604 \ ** terminate. This is the Forth equivalent to inserting an RTS/RET 1605 \ ** instruction in the middle of an assembler subroutine. 1606 ?comp c_exit 1607 ; immediate 1608 1609 : ; \ C: colon-sys -- ; Run: -- ; R: nest-sys -- 1610 \ *G Complete the definition of a new 'colon' word or *\fo{:NONAME} 1611 \ ** code block. 1612 ?comp ?csp c_exit 1613 reveal [compile] [ 1614 ; 1615 IMMEDIATE 1616 1617 -short-branches 1618 : INTERPRET \ -- 1619 \ *G Process the current input line as if it is text entered at 1620 \ ** the keyboard. 1621 begin 1622 ?stack bl word dup c@ 1623 while 1624 find ?dup if 1625 0< state @ and 1626 if compile, else execute then 1627 else 1628 number? ?dup ?undef 1629 state @ if 1630 case 1631 1 of c_lit endof 1632 2 of swap c_lit c_lit endof 1633 #-13 throw 1634 endcase 1635 else 1636 drop 1637 then 1638 then 1639 repeat 1640 drop 1641 ; 1642 +short-branches 1643 1644 : EVALUATE \ i*x c-addr u -- j*x ; interpret the string 1645 \ *G Process the supplied string as though it had been entered via the 1646 \ ** interpreter. 1647 'tib @ >r #tib @ >r >in @ > source-id >r 1648 to-source -1 <source> ! >in off 1649 ['] interpret catch 1650 r> <source> ! r> >in ! r> #tib ! r> 'tib ! 1651 throw 1652 ; 1653 1654 internal 1655 : .throw \ throw# -- 1656 \ *G Display the throw code. Values of 0 and -1 are ignored. 1657 case 1658 0 of endof \ quiet 1659 -1 of endof \ quiet 1660 -2 of 'AbortText @ count type endof \ ABORT" ..." 1661 -13 of ." is undefined" endof 1662 ." Throw code " . 1663 end-case 1664 ; 1665 external 1666 1667 : QUIT \ -- ; R: i*x -- 1668 \ *G Empty the return stack, store 0 in *\fo{SOURCE-ID}, and enter 1669 \ ** interpretation state. *\fo{QUIT} repeatedly *\fo{ACCEPT}s a 1670 \ ** line of input and *\fo{INTERPRET}s it, with a prompt if 1671 \ ** interpreting and *\fo{ECHOING} is on. Note that any task that 1672 \ ** uses *\fo{QUIT} must initialise *\fo{'TIB}, *\fo{BASE}, 1673 \ ** *\fo{IPVEC}, and *\fo{OPVEC}. 1674 xon/xoff off echoing on \ No Xon/Xoff, do Echo 1675 0 <source> ! [compile] [ \ set up 1676 begin 1677 r0 @ rp! \ reset return stack 1678 echoing @ if cr then \ if echoing enabled issue new line 1679 query \ get user input 1680 ['] interpret catch ?dup 0= if \ interpret line 1681 state @ 0= echoing @ 0<> and if \ if interpreting & echoing 1682 ." ok" depth ?dup \ prompt user 1683 if ." -" . then 1684 then 1685 else 1686 .throw s0 @ sp! [compile] [ \ display error, clean up 1687 cr source type \ display input line 1688 cr >in @ 1- spaces ." ^" \ display pointer to error 1689 then 1690 again \ do next line 1691 ; 1692 1693 1694 \ *************** 1695 \ *S Startup code 1696 \ *************** 1697 1698 \ ************* 1699 \ *N Cold chain 1700 \ ************* 1701 \ *P If enabled by the non-zero equate *\fo{COLDCHAIN?} the cold 1702 \ ** start code in *\fo{COLD} will walk a list and execute the xts 1703 \ ** contained in it. The xts must have no stack effect *\fo{( -- )} 1704 \ ** and are added to the list by the phrase: 1705 \ *C ' <wordname> AtCold 1706 \ *P The list is executed in the order in which it was defined so 1707 \ ** that the last word added is executed last. This was done 1708 \ ** for compatibility with VFX Forth, which also contains a 1709 \ ** shutdown chain, in which the last word added is executed 1710 \ ** first. 1711 1712 \ *P If the equate *\fo{COLDCHAIN?} is not defined in the control 1713 \ ** file, a default value of 0 will be defined. 1714 1715 [undefined] ColdChain? [if] 1716 0 equ ColdChain? 1717 [then] 1718 1719 ColdChain? [if] 1720 1721 align 1722 l: ColdChainFirst \ -- addr 1723 \ *G Dummy first entry in ColdChain. 1724 0 , ' noop , 1725 1726 variable ColdChain \ -- addr 1727 \ *G Holds the address of the last entry in the cold chain. 1728 ColdChainFirst ColdChain ! 1729 1730 interpreter 1731 : AtCold \ xt(t) -- 1732 align 1733 chere(t) dup ColdChain @c(t) !c(t) \ last points to new 1734 ColdChain !c(t) \ new becomes old 1735 0 ,c(t) ,c(t) \ lay link to next and xt 1736 ; 1737 target 1738 1739 : AtCold \ xt -- 1740 \ *G Specifiy a new XT to execute when *\fo{COLD} is run. Note 1741 \ ** that the last word added is executed last. *\fo{ATCOLD} can 1742 \ ** be executed interpretively during cross-compilation. The cold 1743 \ ** chain is built in the current *\fo{CDATA} section. 1744 Align 1745 here dup ColdChain @ ! ColdChain ! \ update cold chain 1746 0 , , \ lay link to next and xt 1747 ; 1748 1749 : WalkColdChain \ -- MPE.0000 1750 \ *G Execute all words added to the cold chain. Note that the first 1751 \ ** word added is executed first. 1752 ColdChainFirst 1753 begin 1754 dup 1755 while 1756 dup cell + @ execute \ execute XT 1757 @ \ get next entry 1758 repeat 1759 drop 1760 ; 1761 1762 [then] 1763 1764 1765 \ ==================== 1766 \ *N The COLD sequence 1767 \ ==================== 1768 \ *P At power up, the target executes *\fo{COLD} or the word specified 1769 \ ** by *\fo{MAKE-TURNKEY <name>}, or the word specified as the action 1770 \ ** of an application compiled by the target. 1771 1772 internal 1773 1774 3 cells equ #idhead 1775 1776 : (INIT) \ -- 1777 \ *G Performs the high level Forth startup. See the source code for 1778 \ ** more details. 1779 \ ** INTERNAL. 1780 1781 \ Copy the given RAM table from Flash into RAM. The table may 1782 \ initialise multiple blocks of RAM. The data consists of: 1783 \ len, addr, pageid, len bytes data, len, addr, page, ..., len=0, 1784 init-ram begin 1785 dup @ 1786 while \ len<>0 1787 dup #idhead + over 2@ \ source, dest, len 1788 cmove \ copy 1789 dup @ + #idhead + \ step to next block 1790 repeat 1791 drop 1792 1793 user-reset s0 4 cells cmove \ initialise user vars 1794 s0 @ sp! \ Reset data stack 1795 init-tib 'tib ! \ input buffer pointer 1796 handler off \ no CATCH used yet 1797 init-fence fence 4 cells cmove \ fence, dp, voc-link 1798 0 <source> ! decimal 1799 forth-wordlist dup context ! current ! 1800 0 context cell+ ! 1801 \ only forth definitions \ set up search order 1802 ; 1803 external 1804 1805 : .FREE \ -- 1806 \ *G Return the free dictionary space. 1807 cr APPFLASHEND dp @ - u. ." bytes free Flash" 1808 cr RP-END rp @ - u. ." bytes free RAM" 1809 ; 1810 1811 : Commit \ xt|0 -- 1812 \ *G Preserve the compiled image. If xt is non-zero, that word 1813 \ ** will be executed when the application starts. 1814 dup 0= if drop ['] noop then 1815 to-do start-action \ start up action 1816 DefStart APPSTART /DefStart >Flash \ save application data 1817 ; 1818 1819 : Empty \ -- 1820 \ *G Wipe the application and perform a cold restart. 1821 \ INFOSTART DefStart /DefStart cmove \ relink base system 1822 APPSTART /DefStart FlErase \ wipe application links 1823 APPFLASHSTART /APPFLASH FlErase \ wipe application flash 1824 reboot 1825 ; 1826 1827 : COLD \ -- 1828 \ *G The first high level word executed by default. This word is 1829 \ ** set to be the word executed at power up, but this may be 1830 \ ** overridden by a later use of *\fo{MAKE-TURNKEY <name>} in 1831 \ ** the cross-compiled code. See 1832 \ ** the source code for more details of *\fo{COLD}. 1833 (init) \ start Forth 1834 init-ser \ initialise serial line 1835 console opvec ! \ default i/o channels 1836 console ipvec ! 1837 start-clock 1838 \ perform the application detection and linking 1839 DefStart INFOSTART /DefStart >Flash \ save defaults 1840 APPSTART @ dup -1 <> swap 0<> and if \ FENCE not $FFFF or 0 1841 crcslot @ APPSTART /DefStart + @ = if \ checksums match 1842 APPSTART DefStart /DefStart cmove \ load app 1843 endif 1844 endif 1845 align dp @ @ -1 <> \ Flash at HERE should be erased 1846 if empty endif \ use -1 for 16/32 bit reasons 1847 \ cold chain actions 1848 WalkColdChain \ execute user specified initialisation 1849 \ sign on 1850 CR .cpu .free \ sign on, display free space 1851 start-action \ perform application start up actions 1852 cr cr ." ok" \ display prompt 1853 s0 @ sp! \ reset data stack 1854 quit \ start text interpreter 1855 ; 1856 make-turnkey cold \ Default start-up word. 1857 1858 1859 \ ===================== 1860 \ *S Kernel error codes 1861 \ ===================== 1862 1863 \ *D -1 ABORT 1864 \ *D -2 ABORT" 1865 \ *D -4 Stack underflow 1866 \ *D -13 Undefined word. 1867 \ *D -14 Attempt to interpret a compile only definition. 1868 \ *D -22 Control structure mismatch - unbalanced control structure. 1869 \ *D -121 Attempt to remove with MARKER or FORGET below FENCE in protected dictionary. 1870 \ *D -403 Attempt to compile an interpret only definition. 1871 \ *D -501 Error if not LOADing from a block. 1872 1873 1874 \ ****** 1875 \ *> ### 1876 \ ****** 1877