├── README.md ├── code ├── .mf ├── ansi.rf ├── bug.rf ├── hexdump.rf ├── obj.rf ├── showkeys.rf ├── test_00.rf └── test_01.rf ├── native └── arm │ └── versatilepb │ ├── Makefile │ ├── memmap │ ├── qemu_versatile_start.s │ └── rtc.rf └── src ├── Darwin.mk ├── FreeBSD.mk ├── Linux.mk ├── Makefile └── OneFileForth.c /README.md: -------------------------------------------------------------------------------- 1 | # OneFileForth 2 | 3 | A single file implementation of a non-standard Forth written in the FIG style 4 | This project is hosted on GitHub, and can be cloned as follows: 5 | 6 | git clone http://github.com/paraplegic/OneFileForth . 7 | 8 | ## Building: 9 | 10 | ### HOSTED: 11 | 12 | This project should make out of the box on most HOSTED systems, and particularly 13 | on Linux and/or BSD: 14 | 15 | sudo make install 16 | [sudo] password for rob: 17 | OSTYPE is Linux 18 | Building for Linux 19 | 20 | gcc -g -O2 -o ../bin/off -D NOCHECK -ldl OneFileForth.c 21 | size ../bin/off 22 | text data bss dec hex filename 23 | 46618 138104 35384 220106 35bca ../bin/off 24 | 25 | gcc -g -O2 -o ../bin/offorth -ldl OneFileForth.c 26 | size ../bin/offorth 27 | text data bss dec hex filename 28 | 49627 138104 35384 223115 3678b ../bin/offorth 29 | 30 | cp ../bin/off ../bin/offorth /usr/local/bin 31 | rob@debian9:~/mystuff/OneFileForth/src$ off 32 | -- OneFileForth-Hosted alpha Version: 00.01.56F (en_US.UTF-8) 33 | -- www.ControlQ.com 34 | 35 | ok bye 36 | 37 | rob@debian9:~/mystuff/OneFileForth/src$ offorth 38 | -- OneFileForth-Hosted alpha Version: 00.01.56D (en_US.UTF-8) 39 | -- www.ControlQ.com 40 | 41 | ok bye 42 | 43 | ### TESTING: 44 | 45 | Testing on native platforms is accomplished simply: 46 | 47 | make test 48 | 49 | Check stdout and the logs for error messages. 50 | 51 | 52 | ### NATIVE: 53 | 54 | OneFileForth will build using the arm-eabi-none or arm-eabi-linux toolchain, and will 55 | build for the ARM versatilepb under QEMU. Similar in most respects to the hosted version, 56 | but obviously the C native interface does not work, and you cannot access things like clk and 57 | bye, but the native version will continue to evolve until it is useful on real cards (BBB, Pi and 58 | similar). Assuming you have an appropriate X compilation tool, and QEMU, you can test the native 59 | version by typing: 60 | 61 | make qemu 62 | 63 | arm-linux-gnueabi-as --warn --fatal-warnings -march=armv5t qemu_versatile_start.s -o qemu_versatile_start.o 64 | arm-linux-gnueabi-gcc -c -Wall -O2 -nostdlib -nostartfiles -ffreestanding -march=armv5t -DNATIVE=native -D NOCHECK ../../../src/OneFileForth.c -o OneFileForth.o 65 | ## arm-linux-gnueabi-gcc -c -Wall -O2 -nostdlib -nostartfiles -ffreestanding -march=armv5t -DNATIVE=native ../../../src/OneFileForth.c -o OneFileForth.o 66 | arm-linux-gnueabi-gcc qemu_versatile_start.o OneFileForth.o -nostartfiles -L /usr/arm-linux-gnueabi/lib -T memmap -o OneFileForth.elf -Wl,--build-id=none 67 | arm-linux-gnueabi-objdump -D OneFileForth.elf > OneFileForth.list 68 | arm-linux-gnueabi-objcopy OneFileForth.elf -O binary ../../../bin/OneFileForth-native-arm.bin 69 | qemu-system-arm -M versatilepb -m 256M -nographic -kernel ../../../bin/OneFileForth-native-arm.bin 70 | pulseaudio: set_sink_input_volume() failed 71 | pulseaudio: Reason: Invalid argument 72 | pulseaudio: set_sink_input_mute() failed 73 | pulseaudio: Reason: Invalid argument 74 | -- OneFileForth-Native alpha Version: 00.01.56F (EMBEDDED) 75 | -- www.ControlQ.com 76 | 77 | ok words 78 | quit banner + - * ^ / % abs .s . u. bye words rdepth depth dup ?dup rot nip tuck drop over 79 | swap pick >r r> cells cellsize @ ! r@ r! cr@ cr! h@ h! c@ c! << >> cmove word ascii 80 | ?key key emit type cr dp strings flashsize flash here freespace , (literal) : ; execute call 81 | (colon) ' >name >code >body decimal hex base trace sigval errvar errval errstr warm cold see 82 | (variable) allot create lambda does> constant variable normal immediate [ ] unresolved >mark 83 | >resolve 84 | >= <= == != & and or xor not buf scratch pad ( \ .( " ." count save unsave infile filename 85 | outfile closeout native clks ++ -- utime ops noops do (do) i loop (loop) +loop (+loop) 86 | forget <# # #s hold sign #> utf8 accept find version code data align fill ok 87 | 88 | 89 | To exit the QEMU emulator, hit a cntrl-A followed by an x to exit. 90 | 91 | Note that the banner will indicate whether the version of forth running is a HOSTED or 92 | NATIVE version, the revision number, and whether stack checking is enabled (D)ebug vs a 93 | non-stack checking (F)ast version is running. Not sure why the pulseaudio messages are 94 | being emitted from QEMU, and I'll review those some day ... 95 | 96 | The Makefile will support both the BSD make and the Linux GNU style make 97 | (or gmake on BSD). The OneFileForth.c should compile on cygwin with minor changes 98 | but as I don't run DOS/Windows, I have no need for Cygwin. Sorry, you're on your 99 | own. 100 | 101 | ## Running 102 | *TBD* 103 | 104 | ### Tested 105 | 106 | #### Hosted: 107 | PC-BSD/TrueOS 108 | FreeBSD 10.x, 11.x 109 | Debian Jesse, Stretch 110 | RaspberyPi Zero W running Raspbian Jesse 111 | OSX 10.x 112 | 113 | #### Native: 114 | Qemu ARM VersatilePB 115 | 116 | #### Coming soon: RiscV (native/bsd/linux) 117 | -------------------------------------------------------------------------------- /code/.mf: -------------------------------------------------------------------------------- 1 | 2 | .( loading ./.mf ) 3 | : load dlopen constant ; ( | NULL -- creates lib ptr ) 4 | : entry dlsym dup 0 == if dlerror type cr then ; ( -- looks up a symbol in library ) 5 | : code create , , does> dup @ swap 1 cells + @ native ; ( ptr n -- creates new forth word to call C code ) 6 | : .sep ." -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=" cr ; 7 | : .sd cr .sep . ." :::" .s cr .sep ; 8 | : .space 32 emit ; 9 | ' .space constant print_space 10 | : showkeys begin key dup ascii x == if . ." Exit" cr leave then . begin ?key while key . repeat again ; 11 | : times 0 begin over over - while 3 pick execute ++ repeat drop drop drop ; ( xt n -- ) 12 | : .ss dup type print_space 10 times ; 13 | .( ... done ) cr 14 | 15 | 0 load _libc 16 | 17 | .( loading libc stuff ) 18 | _libc " getuid" entry 0 code uid 19 | _libc " getgid" entry 0 code gid 20 | _libc " time" entry 1 code tick 21 | _libc " clock" entry 0 code clock 22 | _libc " calloc" entry 2 code allocate 23 | _libc " free" entry 1 code free 24 | _libc " system" entry 1 code shell 25 | _libc " gettimeofday" entry 2 code tod 26 | _libc " getenv" entry 1 code env 27 | .( ... done ) cr 28 | 29 | .( loading libQ.so ) 30 | " libQ.so" load _qobj 31 | .( ... done ) cr 32 | 33 | .( loading object entries ) 34 | _qobj " ob_crt" .ss entry 1 code new 35 | _qobj " ob_spawn" .ss entry 2 code child 36 | _qobj " ob_is" .ss entry 2 code is 37 | _qobj " ob_has" .ss entry 3 code has 38 | _qobj " ob_fmt" .ss entry 4 code fmt 39 | _qobj " ob_strtyp" .ss entry 1 code cnv 40 | _qobj " sc_strTyp" .ss entry 1 code dcnv 41 | _qobj " sc_setType" .ss entry 1 code setType 42 | .( ... done ) cr 43 | 44 | ( 0 .sd ) 45 | 46 | .( loading labels ) 47 | " label" save constant str_label 48 | " key" save constant str_key 49 | " type" save constant str_type 50 | .( ... done ) cr 51 | 52 | ( 1 .sd ) 53 | 54 | .( loading class constructs ) 55 | " t_Schema" dup type cnv dup . constant t_Schema cr 56 | " t_Class" dup type cnv dup . constant t_Class cr 57 | " t_Menu" dup type cnv dup . constant t_Menu cr 58 | " t_Field" dup type cnv dup . constant t_Field cr 59 | " t_Trigger" dup type cnv dup . constant t_Trigger cr 60 | " t_Tuple" dup type cnv dup . constant t_Tuple cr 61 | .( ... done ) cr 62 | 63 | ( 2 .sd ) 64 | 65 | .( loading data types ) 66 | " t_integer" dup type dcnv dup . constant dbt_integer cr 67 | " t_string" dup type dcnv dup . constant dbt_string cr 68 | " t_date" dup type dcnv dup . constant dbt_date cr 69 | " t_timestamp" dup type dcnv dup . constant dbt_timestamp cr 70 | " t_double" dup type dcnv dup . constant dbt_double cr 71 | .( ... done ) cr 72 | 73 | ( 3 .sd ) 74 | 75 | .( defining schema ) 76 | " schema" new constant s 77 | s t_Schema is . 78 | s " person" child constant c 79 | c t_Class is . 80 | c " id" child constant f 81 | c str_key " id" has . 82 | 83 | ( 4 .sd ) 84 | 85 | f t_Field is drop 86 | f str_label " Key Field" has drop 87 | f str_type " dbt_integer" has drop 88 | .( ... done ) cr 89 | 90 | s 0 here 2048 fmt . 91 | ." >>>>>>>>>>>>>" cr 92 | here type cr 93 | ." >>>>>>>>>>>>>" cr 94 | 95 | ( 5 .sd ) 96 | 97 | : gt here 0 tod 0 == if here 4 + h@ else ." oops" cr then ; 98 | : mips 0 begin 1 + dup 1000000 < while spin repeat . ; 99 | : tm 0 tick ; 100 | : tx tm mips tm swap - . ; 101 | 102 | " html" save constant html 103 | " a " save constant anchor 104 | 105 | : start ." <" type dup if ." " type then drop ." >" ; 106 | : end ." " ; 107 | 108 | : .html 0 html start ; 109 | : .html_end 0 html end ; 110 | : .anchor anchor start 0 anchor end ." This is a tag" 0 end ; 111 | 112 | 113 | ( 6 .sd ) 114 | 115 | .html cr 116 | " href=www.controlq.com class=blue" .anchor 0 end cr 117 | .html_end . cr 118 | 119 | ( 7 .sd ) 120 | : xxx ." do one time command" cr ; 121 | .( done! ) cr 122 | -------------------------------------------------------------------------------- /code/ansi.rf: -------------------------------------------------------------------------------- 1 | ( 2 | 3 | Terminal escape sequences 4 | 5 | These words implement the ANS vt100 terminal escape commands using 6 | a simple format string (built backwards). 7 | ) 8 | 9 | .( ::: loading ansi library ) cr 10 | 11 | " obj.rf" infile 12 | 13 | 0x1b constant esc 14 | 0x5b constant lbr 15 | 16 | {{ 17 | const >ul 18 | const >ur 19 | const >ll 20 | const >lr 21 | const >hl 22 | const >vl 23 | const >jl 24 | const >jr 25 | }} BoxStyle 26 | 27 | \ create lookup tables for the unicode characters used in box construction. 28 | 29 | \ single box 30 | BoxStyle s_single 31 | s_single 1 cells + 0x250c !++ 0x2510 !++ 0x2514 !++ 0x2518 !++ 0x2500 !++ 0x2502 !++ 0x251c !++ 0x2524 !++ drop 32 | 33 | \ double box 34 | BoxStyle s_double 35 | s_double 1 cells + 0x2554 !++ 0x2557 !++ 0x255a !++ 0x255d !++ 0x2550 !++ 0x2551 !++ 0x2560 !++ 0x2563 !++ drop 36 | 37 | \ rounded corner box 38 | BoxStyle s_rounded 39 | s_rounded 1 cells + 0x256d !++ 0x256e !++ 0x2570 !++ 0x256f !++ 0x2500 !++ 0x2502 !++ 0x251c !++ 0x2524 !++ drop 40 | 41 | \ bold box 42 | BoxStyle s_bold 43 | s_bold 1 cells + 0x250f !++ 0x2513 !++ 0x2517 !++ 0x251b !++ 0x2501 !++ 0x2503 !++ 0x2523 !++ 0x252b !++ drop 44 | 45 | \ get coordinates from the ESC[;R sequence returned by t_cloc 46 | : parse_cursor_coordinates ( buf -- y x ) 47 | 2 + 48 | 0 >r 49 | begin 50 | dup c@ ascii ; over != while 51 | ascii 0 - r> dup 0 != if 10 * then + >r ++ 52 | repeat 53 | drop 54 | ++ 55 | 0 >r 56 | begin 57 | dup c@ ascii R over != while 58 | ascii 0 - r> dup 0 != if 10 * then + >r ++ 59 | repeat 60 | drop 61 | drop 62 | r> r> swap 63 | ; 64 | 65 | \ building the ANSI terminal escape sequences backwards 66 | 67 | \ move cursor to position y x 68 | : t_to ( y x -- ) <# ascii H hold #s drop over ascii ; hold #s lbr hold esc hold #> type drop ; 69 | 70 | \ move cursor up n rows 71 | : t_up ( n -- ) <# ascii A hold #s lbr hold esc hold #> type ; 72 | 73 | \ move cursor down n rows 74 | : t_down ( n -- ) <# ascii B hold #s lbr hold esc hold #> type ; 75 | 76 | \ move cursor forward n cols 77 | : t_fwd ( n -- ) <# ascii C hold #s lbr hold esc hold #> type ; 78 | 79 | \ move cursor backward n cols 80 | : t_bwd ( n -- ) <# ascii D hold #s lbr hold esc hold #> type ; 81 | 82 | \ save current cursor position 83 | : t_c_sav ( -- ) 0 <# ascii s hold lbr hold esc hold #> type ; 84 | 85 | \ return to saved cursor position 86 | : t_c_ret ( -- ) 0 <# ascii u hold lbr hold esc hold #> type ; 87 | 88 | \ clear the entire screen 89 | : t_clear ( -- ) 2 <# ascii J hold #s lbr hold esc hold #> type 0 0 t_to ; 90 | 91 | \ return the current cursor position 92 | : t_cloc ( -- ) 93 | 6 <# ascii n hold #s lbr hold esc hold #> type 94 | buf drop dup 95 | begin 96 | key ascii R over 97 | != while 98 | over c! ++ 99 | repeat 100 | swap c! parse_cursor_coordinates 101 | ; 102 | 103 | \ use a trick to figure out screen size 104 | : t_size ( -- y x ) 999 999 t_to t_cloc ; 105 | 106 | 107 | \ create data objects with methods using the obj.rf library 108 | 109 | {{ 110 | field .position 111 | -- method >at 112 | field .style 113 | -- method >style 114 | field .height 115 | -- const .ht 116 | field .width 117 | -- const .wd 118 | field .draw 119 | -- method >draw 120 | }} Box 121 | 122 | : draw_box ( adr -- ) 123 | >at t_to 124 | >style >ul emit 125 | dup .wd 2 - 0 do 126 | >style >hl emit 127 | loop 128 | >style >ur emit 129 | dup .ht >r 130 | >at r> 0 pt_add t_to 131 | >style >ll emit 132 | dup .wd 2 - 0 do 133 | >style >hl emit 134 | loop 135 | >style >lr emit 136 | >at 1 0 pt_add t_to 137 | dup .ht 1 do 138 | >at i 0 pt_add t_to 139 | >style >vl emit 140 | dup .wd 2 - t_fwd 141 | >style >vl emit 142 | loop 143 | drop 144 | ; 145 | 146 | 10 10 Point bold_loc 147 | 12 12 Point single_loc 148 | 14 14 Point cool_loc 149 | 16 16 Point double_loc 150 | 151 | Box bld 152 | ' bold_loc bld .position ! 153 | ' s_bold bld .style ! 154 | ' draw_box bld .draw ! 155 | 82 bld .width ! 156 | 22 bld .height ! 157 | 158 | Box sng 159 | ' single_loc sng .position ! 160 | ' s_single sng .style ! 161 | ' draw_box sng .draw ! 162 | 78 sng .width ! 163 | 18 sng .height ! 164 | 165 | Box round 166 | ' cool_loc round .position ! 167 | ' s_rounded round .style ! 168 | ' draw_box round .draw ! 169 | 74 round .width ! 170 | 14 round .height ! 171 | 172 | Box dbl 173 | ' double_loc dbl .position ! 174 | ' s_double dbl .style ! 175 | ' draw_box dbl .draw ! 176 | 70 dbl .width ! 177 | 10 dbl .height ! 178 | 179 | : draw_all 180 | utime 181 | dbl >draw 182 | round >draw 183 | sng >draw 184 | bld >draw 185 | utime swap - . ." usecs" cr cr 186 | ; 187 | 188 | -------------------------------------------------------------------------------- /code/bug.rf: -------------------------------------------------------------------------------- 1 | : bug 1 0 / . ; 2 | : d bug ; 3 | : c d ; 4 | : b c ; 5 | : a b ; 6 | -------------------------------------------------------------------------------- /code/hexdump.rf: -------------------------------------------------------------------------------- 1 | ( 2 | code to create a formatted hex dump of a region of memory 3 | not unlike the hexdumps we are all familiar with ... 4 | ) 5 | 6 | .( ::: loading hexdump library ) cr 7 | 8 | : space ( -- ) ascii | emit ; 9 | : spaces ( n -- ) 0 do space loop ; 10 | : .hex ( n -- ) base @ >r hex <# cellsize 0 do # loop ascii _ hold cellsize 0 do # loop ascii x hold ascii 0 hold #> type r> base ! ; 11 | : isPrintable ( n -- n flg ) dup 31 > over 127 < and ; 12 | : hexdump ( adr nrows -- ) 13 | 0 do 14 | dup .hex ascii : emit space 15 | 4 0 do dup i cells + @ .hex space loop 3 spaces 16 | 4 cellsize * 0 do dup i + c@ isPrintable if emit else drop ascii . emit then loop 17 | 4 cells + 18 | cr 19 | loop 20 | drop 21 | ; 22 | -------------------------------------------------------------------------------- /code/obj.rf: -------------------------------------------------------------------------------- 1 | ( 2 | Object type programming in Forth 3 | Simplistic object using create.does> 4 | 1 trace ! 5 | ) 6 | 7 | " hexdump.rf" infile 8 | 9 | .( ::: loading object library ) cr 10 | 11 | : Point create , , does> dup @ swap 1 cells + @ ; 12 | : pt_add ( x y a b -- x+a y+b ) >r >r swap r> + swap r> + ; 13 | : pt_set-y ( n dp -- ) >body 2 cells - ! ; 14 | : pt_set-x ( n dp -- ) >body 1 cells - ! ; 15 | : pt_reset ( y x pfa -- ) dup rot swap pt_set-x pt_set-y ; 16 | 17 | ( 18 | a struct like object 19 | ) 20 | 21 | : {{ 1 ; ( -- n ) 22 | : field ( off -- off++ ) dup ++ swap cells create , does> @ + ; 23 | : const ( off -- off++ ) dup ++ swap cells create , does> @ + @ ; 24 | : method ( off -- off++ ) dup ++ swap cells create , does> @ over + @ dup if execute else drop ." unimplemented method" cr then ; 25 | : .tag ( pfa -- ) @ ; 26 | : }} ( siz -- ) word save dup lambda , , does> dup @ create , 1 cells + @ allot does> ; 27 | 28 | : @++ ( ptr -- ptr+1) dup @ swap 1 cells + ; 29 | : !++ ( ptr val -- ptr++ ) over ! 1 cells + ; 30 | -------------------------------------------------------------------------------- /code/showkeys.rf: -------------------------------------------------------------------------------- 1 | : showkeys begin key dup ascii x == if . ." Exit" cr leave then . begin ?key while key . repeat again ; 2 | 3 | : key. key dup emit ; 4 | 5 | : gets ( n -- ptr ) 6 | here >r 7 | begin 8 | dup 0 > while 9 | key. r> dup ++ >r c! -- 10 | repeat 11 | r> c! here 12 | ; 13 | 14 | -------------------------------------------------------------------------------- /code/test_00.rf: -------------------------------------------------------------------------------- 1 | .( ::: Test file for One File Forth ::: ) cr 2 | 3 | 1 constant on 4 | 0 constant off 5 | 32 constant space 6 | 1024 dup * constant 1Meg 7 | freespace cellsize / constant start_mem 8 | utime constant start_time 9 | " test.log" save constant log_file 10 | 11 | : set_trace trace ! ; 12 | : set_log log_file outfile ; 13 | : clr_log closeout ; 14 | : tab 9 emit ; 15 | : done 13 emit 8 0 do tab loop ." [DONE]" cr ; 16 | 17 | .( ::: Loop test 1 begin-while-repeat ::: ) 18 | : operations begin dup while -- repeat drop ; 19 | done 20 | noops 1Meg dup tab . ." loop operations " utime swap operations utime swap - 21 | ops . ." forth operations in " . ." microseconds" cr 22 | 23 | .( ::: code decompiled ::: ) 24 | set_log 25 | ' operations see 26 | clr_log 27 | done 28 | 29 | .( ::: Loop test 2 begin-again ::: ) 30 | : fast 1Meg begin -- dup 0 == if drop leave then again ; 31 | done 32 | noops 1Meg tab . ." loop operations in " utime fast utime ops . ." forth operations in " swap - . ." microseconds " cr 33 | 34 | .( ::: code decompiled ::: ) 35 | set_log 36 | ' fast see 37 | clr_log 38 | done 39 | 40 | .( ::: tracing 10 operations [indefinite loop] ::: ) 41 | set_log 42 | on set_trace 43 | 10 operations 44 | off set_trace 45 | clr_log 46 | done 47 | 48 | .( ::: testing definite loop ::: ) 49 | : tstdo 0 do loop ; 50 | done 51 | noops 1Meg dup tab . ." do loop operations " utime swap tstdo utime swap - 52 | ops . ." forth operations in " . ." microseconds" cr 53 | 54 | .( ::: code decompiled ::: ) 55 | set_log 56 | ' tstdo see 57 | clr_log 58 | done 59 | 60 | .( ::: tracing 10 do loop iterations ::: ) 61 | set_log 62 | on set_trace 63 | 10 tstdo 64 | off set_trace 65 | clr_log 66 | done 67 | 68 | .( ::: arithmetic tests ::: ) 69 | set_log 70 | ." addition: 3 == " 1 2 + . cr 71 | ." subraction: 0 == " 2 2 - . cr 72 | ." multiplication: 81 == " 9 9 * . cr 73 | ." division: 4 == " 12 3 / . cr 74 | clr_log 75 | done 76 | 77 | .( ::: ) 1Meg . .( 1 byte tty i/o operations ) cr 78 | : sspin 0 do spin loop ; 79 | utime 1Meg sspin utime swap - ops tab . ." forth operations in " . .( microseconds ) done cr 80 | 81 | .( ::: stack tests ::: ) 82 | set_log 83 | 1 2 3 4 5 84 | .( ::: stack depth is ) depth . cr 85 | .( ::: stack view is ) .s .( ::: ) cr 86 | .( ::: clear stack by printing ::: ) cr 87 | . . . . . cr 88 | clr_log 89 | done 90 | 91 | .( ::: loop backwards by 2 ::: ) 92 | : bkw 0 100 do i . -2 +loop ; 93 | set_log 94 | bkw cr 95 | clr_log 96 | done 97 | 98 | .( ::: loop forwards by 2 ::: ) 99 | : fwd 100 0 do i . 2 +loop ; 100 | set_log 101 | fwd cr 102 | clr_log 103 | done 104 | 105 | .( ::: conditional tests [modulo 5] ::: ) 106 | : conditional 0 do i 5 % if 46 emit else i . then loop ; 107 | set_log 108 | 100 conditional cr 109 | clr_log 110 | done 111 | 112 | .( ::: found in comp.lang.forth thread ::: ) 113 | : test begin ?dup if -- else leave then again ; 114 | utime 100000000 test utime swap - . ." u-secs" cr 115 | 116 | .( ::: word list ::: ) 117 | set_log words clr_log done cr 118 | 119 | .( ::: end of tests ::: ) cr 120 | .( ::: output can be viewed in file ) log_file type space emit ." ::: " cr 121 | .( ::: error: ) errval dup . errstr type cr 122 | .( ::: total memory usage: ) 123 | freespace cellsize / start_mem swap - . ." bytes." cr 124 | .( ::: total elapsed time: ) 125 | utime start_time - 1000000 / . ." seconds." cr 126 | 127 | freespace forget freespace swap - . ." bytes returned" cr 128 | words cr cr bye 129 | -------------------------------------------------------------------------------- /code/test_01.rf: -------------------------------------------------------------------------------- 1 | .( ::: loading library interface ::: ) cr 2 | 3 | 0 constant off 4 | 1 constant on 5 | 6 | : code_trace ( flg -- :: set trace on or off ) 7 | trace ! 8 | ; 9 | 10 | : load ( | NULL -- :: creates lib ptr ) 11 | dlopen constant 12 | ; 13 | 14 | : entry ( -- :: looks up a symbol in library ) 15 | dlsym dup 0 == if 16 | dlerror type cr 17 | then 18 | ; 19 | 20 | : code ( ptr n -- :: creates new forth word to call C code in ptr with n args ) 21 | create 22 | , , 23 | does> 24 | dup @ swap 1 cells + @ 25 | native 26 | ; 27 | 28 | : showkeys begin key dup ascii x == if . ." Exit" cr leave then . begin ?key while key . repeat again ; 29 | 30 | : times ( xt n -- :: execute token n times the hard way ) 31 | 0 begin 32 | over over - while 33 | 2 pick execute ++ 34 | repeat 35 | drop drop drop 36 | ; 37 | : timex ( xt n -- :: execute token n times more efficiently ) 38 | 0 do 39 | dup execute 40 | loop 41 | drop 42 | ; 43 | 44 | 45 | .( ::: pass a path or NULL to load ::: ) cr 46 | .( ::: NULL means loading libc library as _libc ::: ) cr 47 | 0 load _libc 48 | 49 | .( ::: perform entry lookups on local text ::: ) cr 50 | _libc " getuid" entry 0 code uid 51 | _libc " getgid" entry 0 code gid 52 | _libc " time" entry 1 code tick 53 | _libc " clock" entry 0 code clock 54 | _libc " calloc" entry 2 code allocate 55 | _libc " free" entry 1 code free 56 | _libc " system" entry 1 code shell 57 | _libc " gettimeofday" entry 2 code tod 58 | _libc " getenv" entry 1 code env 59 | _libc " popen" entry 2 code popen 60 | _libc " pclose" entry 1 code pclose 61 | _libc " fileno" entry 1 code fileno 62 | 63 | 64 | ." uid = " uid . cr 65 | ." gid = " gid . cr 66 | 67 | ." USER = " 68 | " USER" env type cr 69 | 70 | : .uid ( -- ) 71 | uid . 72 | ; 73 | 74 | utime ' .uid 10 times utime swap - . ." usecs" cr 75 | utime ' .uid 10 timex utime swap - . ." usecs" cr 76 | 77 | .( ::: create string constants for later use ::: ) cr 78 | " /bin/ls ./*" save constant ls 79 | " r" save constant read_only 80 | 81 | : get_io ( fd -- ) 82 | begin 83 | dup 0 1000 waitrdy if ( fd -- fd ) ( duplicate the file descriptor, wait 0. sec and 10000 usecs for i/o ) 84 | dup 100 rcvtty if ( fd -- fd ) ( receive up to 100 characters ) 85 | type ( fd addr -- fd ) ( just output it for now ) 86 | else 87 | ." on input" cr drop leave 88 | then 89 | then 90 | again 91 | ; 92 | 93 | off code_trace 94 | .( ::: open a pipe to the ls command ::: ) cr 95 | ls read_only popen constant fptr 96 | ." file pointer: " fptr . ." converts to fd: " 97 | fptr fileno dup . cr get_io .( ) 98 | ." closing pipe:" fptr pclose . ." worked." drop cr 99 | 100 | freespace forget freespace swap - . ." bytes returned" cr 101 | forget words cr cr bye 102 | -------------------------------------------------------------------------------- /native/arm/versatilepb/Makefile: -------------------------------------------------------------------------------- 1 | 2 | SRC = ../../../src 3 | OUT = ../../../bin 4 | 5 | ARCH = arm 6 | OS = native 7 | OSTYPE != uname -s 8 | 9 | include $(SRC)/$(OSTYPE).mk 10 | 11 | AARCH = -march=armv5t 12 | AOPS = --warn --fatal-warnings $(AARCH) 13 | COPS = -Wall -O2 -nostdlib -nostartfiles -ffreestanding $(AARCH) -DNATIVE=$(OS) 14 | 15 | all: $(OUT)/OneFileForth-$(OS)-$(ARCH).bin 16 | 17 | $(OUT)/OneFileForth-$(OS)-$(ARCH).bin : qemu_versatile_start.o OneFileForth.o memmap 18 | $(ARMGNU)-gcc qemu_versatile_start.o OneFileForth.o -nostartfiles $(LDPTH) -T memmap -o OneFileForth.elf -Wl,--build-id=none 19 | $(ARMGNU)-objdump -D OneFileForth.elf > OneFileForth.list 20 | $(ARMGNU)-objcopy OneFileForth.elf -O binary $(OUT)/OneFileForth-$(OS)-$(ARCH).bin 21 | 22 | qemu_versatile_start.o : qemu_versatile_start.s 23 | $(ARMGNU)-as $(AOPS) qemu_versatile_start.s -o qemu_versatile_start.o 24 | 25 | OneFileForth.o : $(SRC)/OneFileForth.c 26 | $(ARMGNU)-gcc -c $(COPS) -D NOCHECK $(SRC)/OneFileForth.c -o OneFileForth.o 27 | ## $(ARMGNU)-gcc -c $(COPS) $(SRC)/OneFileForth.c -o OneFileForth.o 28 | 29 | qemu: $(OUT)/OneFileForth-$(OS)-$(ARCH).bin 30 | qemu-system-arm -M versatilepb -m 256M -nographic -kernel $(OUT)/OneFileForth-$(OS)-$(ARCH).bin 31 | 32 | map: 33 | $(ARMGNU)-gcc qemu_versatile_start.o OneFileForth.o -nostartfiles $(LDPTH) -T memmap -o OneFileForth.elf -Wl,--build-id=none -Wl,--print-map > load.map 34 | 35 | clean: 36 | rm -rf *.o *.bin *.list *.elf *.map 37 | 38 | realclean: clean 39 | rm -rf $(OUT)/OneFileForth-$(OS)-$(ARCH).bin 40 | -------------------------------------------------------------------------------- /native/arm/versatilepb/memmap: -------------------------------------------------------------------------------- 1 | 2 | /* memmap */ 3 | MEMORY 4 | { 5 | ram : ORIGIN = 0x00010000, LENGTH = 1024M 6 | } 7 | 8 | SECTIONS 9 | { 10 | .text : { *(.text*) } > ram 11 | .bss : { *(.text*) } > ram 12 | } 13 | 14 | -------------------------------------------------------------------------------- /native/arm/versatilepb/qemu_versatile_start.s: -------------------------------------------------------------------------------- 1 | 2 | .globl _start 3 | _start: 4 | b reset 5 | b hang 6 | b hang 7 | b hang 8 | 9 | b hang 10 | b hang 11 | b hang 12 | b hang 13 | 14 | b hang 15 | b hang 16 | b hang 17 | b hang 18 | 19 | b hang 20 | b hang 21 | b hang 22 | b hang 23 | 24 | reset: 25 | mov sp,#0x10000 26 | bl notmain 27 | hang: 28 | b hang 29 | 30 | .globl GETPC 31 | GETPC: 32 | mov r0,pc 33 | bx lr 34 | 35 | .globl PUT32 36 | PUT32: 37 | str r1,[r0] 38 | bx lr 39 | 40 | .globl PUT16 41 | PUT16: 42 | strh r1,[r0] 43 | bx lr 44 | 45 | .globl PUT8 46 | PUT8: 47 | strb r1,[r0] 48 | bx lr 49 | 50 | .globl GET32 51 | GET32: 52 | ldr r0,[r0] 53 | bx lr 54 | 55 | .globl GET16 56 | GET16: 57 | ldrh r0,[r0] 58 | bx lr 59 | 60 | .globl GET8 61 | GET8: 62 | ldrb r0,[r0] 63 | bx lr 64 | -------------------------------------------------------------------------------- /native/arm/versatilepb/rtc.rf: -------------------------------------------------------------------------------- 1 | 0x101e8000 constant rtc 2 | -------------------------------------------------------------------------------- /src/Darwin.mk: -------------------------------------------------------------------------------- 1 | LDOPTS:= 2 | CC:=clang 3 | MAP:=-Wl,--print-map 4 | 5 | ARMGNU ?= arm-none-eabi 6 | LDPTH ?= /usr/local/lib/gcc/arm-none-eabi/5.3.0/libgcc.a 7 | -------------------------------------------------------------------------------- /src/FreeBSD.mk: -------------------------------------------------------------------------------- 1 | LDOPTS:= 2 | CC:=clang 3 | MAP:=-Wl,--print-map 4 | 5 | ARMGNU ?= arm-none-eabi 6 | LDPTH ?= /usr/local/lib/gcc/arm-none-eabi/5.3.0/libgcc.a 7 | -------------------------------------------------------------------------------- /src/Linux.mk: -------------------------------------------------------------------------------- 1 | LDOPTS:=-ldl 2 | MAP:=-Wl,--print-map 3 | CC:=gcc 4 | 5 | ARMGNU ?= arm-linux-gnueabi 6 | ## Debian Jessie ... crosstools 7 | ## LDPTH ?= /usr/lib/gcc/arm-linux-gnueabi/4.9/libgcc.a 8 | ## Debian Stretch ... crosstools 9 | LDPTH ?= -L /usr/arm-linux-gnueabi/lib 10 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | ## 2 | ## Trivial makefile for the OneFileForth project 3 | ## By default creates a "safe" interpreter (forth) 4 | ## which checks stack depth on all (?) primitives. 5 | ## In addition the off executable is generated with 6 | ## -D NOCHEK set on the compile line ... for time 7 | ## sensitive applications ... 8 | ## 9 | 10 | ## 11 | ## This makefile should work for either BSD Make, or 12 | ## gnu Make (gmake on BSD), and compile/link accordingly. 13 | ## 14 | 15 | OUT =../bin 16 | FRT =../code 17 | SRC =OneFileForth.c 18 | OBJ =$(OUT)/off $(OUT)/offorth 19 | FAST=-D NOCHECK 20 | CCOPT=-g -O2 21 | OSTYPE != uname -s 22 | 23 | ## mac hack ... 24 | ifeq ($(OSTYPE),) 25 | OSTYPE := Darwin 26 | endif 27 | 28 | ## include $(OSTYPE).mk 29 | 30 | all: $(OBJ) 31 | @echo $(OSTYPE) 32 | 33 | 34 | $(OUT): 35 | mkdir -p $(OUT) 36 | 37 | $(OUT)/off: $(OUT) $(SRC) 38 | @echo "OSTYPE is $(OSTYPE)" 39 | @echo "Building for $(OSTYPE)" 40 | $(CC) $(CCOPT) -o $@ $(FAST) $(SRC) $(LDOPTS) 41 | size $@ 42 | 43 | $(OUT)/offorth: $(SRC) 44 | $(CC) $(CCOPT) -o $@ $(LDOPTS) $(SRC) 45 | size $@ 46 | 47 | clean: 48 | rm -rf $(OBJ) 49 | rm -rf test.log 50 | rm -rf *.out 51 | rm -rf *.o 52 | rm -rf *.elf 53 | rm -rf *.bin 54 | rm -rf *.list 55 | rm -rf cscope.out 56 | rm -rf load.map 57 | rm -rf *.s 58 | 59 | realclean: clean 60 | rm -rf $(OUT)/* 61 | 62 | map: $(SRC) 63 | @echo "Building loadmap for $(OSTYPE)" 64 | $(CC) $(CCOPT) -o ./tmp.$$ $(FAST) $(LDOPTS) $(SRC) $(MAP) > load.map 65 | rm -rf ./tmp.$$ 66 | 67 | edit: $(SRC) 68 | cscope -b $(SRC) 69 | 70 | test: $(OBJ) $(FRT)/test_00.rf 71 | $(OUT)/off -i $(FRT)/test_00.rf 72 | $(OUT)/off -i $(FRT)/test_01.rf 73 | $(OUT)/offorth -i $(FRT)/test_00.rf 74 | $(OUT)/offorth -i $(FRT)/test_01.rf 75 | 76 | status: realclean 77 | git status 78 | 79 | install: $(OBJ) 80 | cp $(OBJ) /usr/local/bin 81 | -------------------------------------------------------------------------------- /src/OneFileForth.c: -------------------------------------------------------------------------------- 1 | /* 2 | -- OneFileForth: The evolution of a C based forth interpreter 3 | first written in 1982 (RForth), and re-written in 2008 to be 4 | embedded on [sic] less powerful hardware. This (third) version 5 | was designed from the outset to be variable cell sized, compiled 6 | from a single source file, and with the ability to run on hosted 7 | operating systems or natively on the more capable SoC's on the 8 | smaller end. 9 | 10 | Written by Robert S. Sciuk of Control-Q Research 11 | Copyright 1982 - 2017. 12 | 13 | LICENSE: 14 | 15 | This code is offered into the public domain with no usage restrictions 16 | under similar terms to SQLite, but with the one additional proviso that 17 | OneFileForth and/or its derivatives must never be encumbered in any way 18 | by a more restrictive license, and most specifically no GPL license of 19 | any sort (including LGPL) may be applied. Otherwise, and to quote 20 | Dr. D.R. Hipp, author of SQLite: 21 | 22 | "May you do good and not evil 23 | May you find forgiveness for yourself and forgive others 24 | May you share freely, never taking more than you give." 25 | 26 | To use, simply download this file, and use your trusty C compiler: 27 | 28 | clang -o off -D NOCHECK -O2 OneFileForth.c 29 | 30 | Some hosted systems might require the -ldl option, and embedded systems 31 | might require a bit more effort. No documentation is yet available, 32 | and no warranty is offered, expressed or implied. Enjoy. 33 | 34 | */ 35 | 36 | #define MAJOR "00" 37 | #define MINOR "01" 38 | #define REVISION "67" 39 | 40 | #include 41 | // #include 42 | 43 | // trying to avoid this to allow 44 | // bare metal support ... 45 | #ifdef NEVER 46 | #include 47 | #include 48 | #endif 49 | 50 | #ifndef register 51 | #define register 52 | #endif 53 | 54 | #if defined( unix ) & !defined(linux) 55 | #include 56 | #include 57 | #include 58 | #include 59 | #include 60 | #include 61 | #include 62 | #include 63 | #define HOSTED 64 | #endif 65 | 66 | #if defined( linux ) || defined( __APPLE__ ) 67 | #include 68 | #include 69 | #include 70 | #include 71 | #include 72 | #include 73 | #include 74 | #include 75 | #include 76 | #define HOSTED 77 | #endif 78 | 79 | #if defined (__WIN32__) 80 | #include 81 | #define HOSTED 82 | #endif 83 | 84 | // word size will be derived from the architecture 85 | // compiler predefines, and inferred as follows: 86 | #if defined (avr) || defined (AVR) || defined( __riscv ) 87 | #define NATIVE 88 | #include 89 | #define _WORDSIZE 2 90 | #ifndef NULL 91 | #define NULL 0 92 | #endif 93 | #endif 94 | 95 | #if defined (i386) || defined (__arm__) || defined (AVR32) || defined(powerpc) || defined( __riscv ) 96 | #define _WORDSIZE 4 97 | #endif 98 | 99 | #if defined __x86_64 100 | #define _WORDSIZE 8 101 | #endif 102 | 103 | // by pushing NATIVE on the compile line, we will 104 | // override the HOSTED (default) mode, and not rely 105 | // upon system calls including read()/write() to exist. 106 | #ifdef NATIVE 107 | #undef HOSTED 108 | #define sz_FLASH 8192 // cells 109 | #define FLASH_INIT_VAL 0xdead 110 | #endif 111 | 112 | #define sz_INBUF 127 // bytes 113 | #define sz_STACK 32 // cells 114 | #define sz_ColonDefs 1024 // # entries 115 | #define sz_TMPBUFFER 2048 // total buffer queue 116 | #define nm_TMPBUFFER 8 // number of buffers 117 | 118 | #ifndef sz_FLASH 119 | #define sz_FLASH 16384 // cells 120 | #define FLASH_INIT_VAL 0xdeadbeef 121 | #endif 122 | 123 | #ifdef HOSTED 124 | #include 125 | #include 126 | 127 | #include 128 | #include 129 | #include 130 | #include 131 | #include 132 | #include 133 | 134 | volatile sig_atomic_t sigval = 0 ; 135 | 136 | #define OFF_PATH "OFF_PATH" 137 | 138 | #if !defined( __WIN32__ ) 139 | struct termios tty_normal_state ; 140 | #endif 141 | #define FLAVOUR "Hosted" 142 | #define sz_FILES 4 /* nfiles */ 143 | #define INPUT InputStack[ in_This ].file 144 | #define OUTPUT out_files[ out_This ] 145 | jmp_buf env ; 146 | #endif 147 | 148 | #ifdef NATIVE 149 | #define FLAVOUR "Native" 150 | #define sz_FILES 1 /* nfiles */ 151 | #define INPUT 0 152 | #define OUTPUT 1 153 | #ifndef NULL 154 | #define NULL 0 155 | #endif 156 | #endif 157 | 158 | int in_This = -1, in_files[ sz_FILES ] = { 0 } ; 159 | int out_This = 0, out_files[ sz_FILES ] = { 1 } ; 160 | 161 | #if _WORDSIZE == 2 162 | typedef int16_t Wrd_t ; 163 | typedef uint16_t uWrd_t ; 164 | typedef int8_t Hlf_t ; 165 | typedef uint8_t uHlf_t ; 166 | #define _HALFMASK 0xff 167 | #endif 168 | 169 | #if _WORDSIZE == 4 170 | typedef int32_t Wrd_t ; 171 | typedef uint32_t uWrd_t ; 172 | typedef int16_t Hlf_t ; 173 | typedef uint16_t uHlf_t ; 174 | #define _HALFMASK 0xffff 175 | #endif 176 | 177 | #if _WORDSIZE == 8 178 | typedef int64_t Wrd_t ; 179 | typedef uint64_t uWrd_t ; 180 | typedef int32_t Hlf_t ; 181 | typedef uint32_t uHlf_t ; 182 | #define _HALFMASK 0xffffffff 183 | #endif 184 | 185 | #if !defined(_WORDSIZE) 186 | typedef int Wrd_t ; 187 | typedef unsigned int uWrd_t ; 188 | typedef short int Hlf_t ; 189 | typedef unsigned Hlf_t uHlf_t ; 190 | #endif 191 | 192 | typedef void (*Fptr_t)() ; 193 | typedef Wrd_t (*Cptr_t)() ; 194 | typedef char * Str_t ; 195 | typedef int8_t Byt_t ; 196 | typedef uint8_t uByt_t ; 197 | typedef void Nul_t ; 198 | typedef void * Opq_t ; 199 | 200 | typedef Wrd_t Cell_t ; 201 | typedef uWrd_t uCell_t ; 202 | 203 | #define StartOf(x) (&x[0]) 204 | 205 | // -- a data stack ... 206 | Cell_t stack[sz_STACK+1] = { 0 } ; 207 | Cell_t *tos = (Cell_t *) StartOf( stack ) ; 208 | 209 | // -- and a return stack ... 210 | Cell_t rstack[sz_STACK+1] = { 0 } ; 211 | Cell_t *rtos = (Cell_t *) StartOf( rstack ) ; 212 | 213 | // -- and a user stack ... 214 | Cell_t ustack[sz_STACK+1] = { 0 } ; 215 | Cell_t *utos = (Cell_t *) StartOf( ustack ) ; 216 | 217 | // -- some input and scratch buffers ... 218 | Byt_t input_buffer[ sz_FILES * sz_INBUF ] = { 0 } ; 219 | Byt_t *inbuf[] = { 220 | (Byt_t *) (input_buffer + (0 * sz_INBUF)), 221 | #ifdef HOSTED 222 | (Byt_t *) (input_buffer + (1 * sz_INBUF)), 223 | (Byt_t *) (input_buffer + (2 * sz_INBUF)), 224 | (Byt_t *) (input_buffer + (3 * sz_INBUF)), 225 | #endif // HOSTED 226 | NULL 227 | } ; 228 | 229 | // temp buffer circular queue ... 230 | // see implementation below for details. 231 | #define CQ_MAX_BUFFER 65535 232 | #define CQ_MIN_CHUNKS 1 233 | 234 | typedef struct _cque_ { 235 | Str_t cq_memory ; 236 | Wrd_t cq_memsize ; 237 | Wrd_t cq_n_elements ; 238 | Wrd_t cq_chunksize ; 239 | Wrd_t cq_next ; 240 | Str_t cq_buffer ; 241 | } Cir_Queue_t ; 242 | 243 | // temp buffer public interface ... 244 | Cir_Queue_t *tb_create( Cir_Queue_t *Q, Byt_t *chunk, Wrd_t size, Wrd_t n_elements ) ; 245 | Cir_Queue_t *tb_destroy( Cir_Queue_t *CQ ) ; 246 | int tb_bufsize( Cir_Queue_t *CQ ) ; 247 | int tb_nbufs( Cir_Queue_t *CQ ) ; 248 | void *tb_get( Cir_Queue_t *CQ ) ; 249 | 250 | Cir_Queue_t T ; 251 | Cir_Queue_t *TB = (Cir_Queue_t *) NULL ; 252 | Byt_t tmp_buffer[sz_TMPBUFFER] = { 0 } ; 253 | 254 | uCell_t _ops = 0 ; 255 | 256 | #ifdef HOSTED 257 | Str_t off_path = (Str_t) NULL ; 258 | #endif 259 | 260 | // -- useful macros ... 261 | #define v_Off 0 262 | #define v_On 1 263 | #define push( x ) *(++tos) = (Cell_t) x 264 | #define pop() *(tos--) 265 | #define nos tos[-1] 266 | #define rpush( x ) *(++rtos) = x 267 | #define rpop() *(rtos--) 268 | #define upush( x ) *(++utos) = x 269 | #define upop() *(utos--) 270 | #define rnos (rtos-1) 271 | #define isNul( x ) (x == NULL) 272 | #define WHITE_SPACE " \t\r\n" 273 | #define EOL "\n\r" 274 | #define inEOF "" 275 | #define MaxStr( x, y ) ((str_length( x ) > str_length( y )) ? str_length( x ) : str_length( y )) 276 | #define isMatch( x, y ) (str_match( (char *) x, (char *) y, MaxStr( (char *) x, (char *) y ))) 277 | #define __THIS__ ( (Str_t) __FUNCTION__ ) 278 | #define throw( x ) err_throw( __THIS__, __LINE__, x ) 279 | #define Abs( x ) ((x < 0) ? (x*-1) : x) 280 | #define UNUSED( x ) x __attribute__((unused)) 281 | 282 | // nocheck determines argument checking at runtime, and also 283 | // will determine if temporary buffers are cleared 284 | #ifdef NOCHECK 285 | #define chk( x ) {} 286 | #define dbg 'F' 287 | #else 288 | #define chk( x ) do { if( !checkstack( x, (Str_t) __func__ ) ) return ; } while(0) 289 | #define dbg 'D' 290 | #endif 291 | 292 | 293 | /* 294 | -- forth primitives must be pre-declared ... 295 | */ 296 | Wrd_t checkstack(); 297 | 298 | void quit(); 299 | void banner(); 300 | void add(); 301 | void subt(); 302 | void mult(); 303 | void exponent(); 304 | void divide(); 305 | void modulo(); 306 | void absolute(); 307 | void dotS(); 308 | void dot(); 309 | void udot(); 310 | void bye(); 311 | void prompt(); 312 | void words(); 313 | void rdepth(); 314 | void depth(); 315 | void dupe(); 316 | void rot(); 317 | void nip(); 318 | void tuck(); 319 | void qdupe(); 320 | void drop(); 321 | void over(); 322 | void swap(); 323 | void pick(); 324 | void toR(); 325 | void Rto(); 326 | void Eof(); 327 | void cells(); 328 | void cellsize(); 329 | void wrd_fetch(); 330 | void wrd_store(); 331 | void reg_fetch(); 332 | void reg_store(); 333 | void crg_fetch(); 334 | void crg_store(); 335 | void hlf_fetch(); 336 | void hlf_store(); 337 | void byt_fetch(); 338 | void byt_store(); 339 | void lft_shift(); 340 | void rgt_shift(); 341 | void cmove(); 342 | void word(); 343 | void ascii(); 344 | void q_key(); 345 | void key(); 346 | void emit(); 347 | void type(); 348 | void cr(); 349 | void dp(); 350 | void stringptr(); 351 | void flashsize(); 352 | void flashptr(); 353 | void here(); 354 | void freespace(); 355 | void comma(); 356 | void doLiteral(); 357 | void colon(); 358 | void compile(); 359 | void semicolon(); 360 | void call() ; 361 | void execute() ; 362 | void doColon() ; 363 | void tick() ; 364 | void nfa() ; 365 | void cfa() ; 366 | void pfa() ; 367 | void decimal() ; 368 | void hex() ; 369 | void sigvar() ; 370 | void errvar() ; 371 | void errval() ; 372 | void errstr() ; 373 | void errmax() ; 374 | void base() ; 375 | void trace() ; 376 | void resetter() ; 377 | void cold() ; 378 | void see() ; 379 | void pushPfa() ; 380 | void does() ; 381 | void allot() ; 382 | void create() ; 383 | void lambda() ; 384 | void constant() ; 385 | void variable() ; 386 | void pvState() ; 387 | void imState() ; 388 | void normal() ; 389 | void immediate() ; 390 | void unresolved(); 391 | void fwd_mark(); 392 | void fwd_resolve(); 393 | void bkw_mark(); 394 | void bkw_resolve(); 395 | void q_branch(); 396 | void branch(); 397 | void begin(); 398 | void again(); 399 | void While(); 400 | void Repeat(); 401 | void Leave(); 402 | void Until(); 403 | void If(); 404 | void Else(); 405 | void Then(); 406 | void lt(); 407 | void gt(); 408 | void ge(); 409 | void le(); 410 | void eq(); 411 | void ne(); 412 | void And(); 413 | void and(); 414 | void or(); 415 | void xor(); 416 | void not(); 417 | void Buf(); 418 | void nBufs(); 419 | void pad(); 420 | void comment(); 421 | void flushtoeol(); 422 | void dotcomment(); 423 | void quote(); 424 | void dotquote(); 425 | void count(); 426 | void ssave(); 427 | void unssave(); 428 | void infile(); 429 | void filename(); 430 | void outfile(); 431 | void closeout(); 432 | #ifdef HOSTED 433 | void isfile(); 434 | void sndtty(); 435 | void rcvtty(); 436 | void opentty(); 437 | void closetty(); 438 | void waitrdy(); 439 | void qdlopen(); 440 | void qdlclose(); 441 | void qdlsym(); 442 | void qdlerror(); 443 | void spinner(); 444 | void path(); 445 | #endif /* HOSTED */ 446 | void last_will(); 447 | void callout(); 448 | void clkspersec(); 449 | void plusplus(); 450 | void minusminus(); 451 | void utime(); 452 | void ops(); 453 | void noops(); 454 | void qdo(); 455 | void do_do(); 456 | void do_I(); 457 | void loop(); 458 | void do_loop(); 459 | void ploop(); 460 | void do_ploop(); 461 | void forget(); 462 | void fmt_start(); 463 | void fmt_digit(); 464 | void fmt_num(); 465 | void fmt_hold(); 466 | void fmt_sign(); 467 | void fmt_end(); 468 | void utf8_encode(); 469 | void accept(); 470 | void dump(); 471 | void find(); 472 | void version(); 473 | void code(); 474 | void data(); 475 | void align(); 476 | void fill(); 477 | void it_set(); 478 | void it_reset(); 479 | void it_doit( int sig ); 480 | 481 | /* 482 | -- dictionary is simply an array of struct ... 483 | */ 484 | 485 | typedef enum { 486 | Normal, 487 | Immediate, 488 | Undefined 489 | } Flag_t ; 490 | 491 | typedef struct _inbuf_ { 492 | Wrd_t file ; 493 | Wrd_t bytes_read ; 494 | Wrd_t bytes_this ; 495 | Wrd_t in_line ; 496 | Str_t name ; 497 | Str_t bytes ; 498 | } Input_t ; 499 | 500 | Input_t InputStack[sz_FILES] = { 501 | { .file = -1, .bytes_read = -1, .bytes_this = -1, .in_line = 0, .name = (Str_t) NULL, .bytes = (Str_t) &inbuf[0] }, 502 | #ifdef HOSTED 503 | { .file = -1, .bytes_read = -1, .bytes_this = -1, .in_line = 0, .name = (Str_t) NULL, .bytes = (Str_t) &inbuf[1] }, 504 | { .file = -1, .bytes_read = -1, .bytes_this = -1, .in_line = 0, .name = (Str_t) NULL, .bytes = (Str_t) &inbuf[2] }, 505 | { .file = -1, .bytes_read = -1, .bytes_this = -1, .in_line = 0, .name = (Str_t) NULL, .bytes = (Str_t) &inbuf[3] }, 506 | #endif // HOSTED 507 | } ; 508 | 509 | typedef struct _dict_ { 510 | Fptr_t cfa ; 511 | Str_t nfa ; 512 | Flag_t flg ; 513 | Cell_t *pfa ; 514 | } Dict_t ; 515 | 516 | Dict_t Primitives[] = { 517 | { quit, "quit", Normal, NULL }, 518 | { banner, "banner", Normal, NULL }, 519 | { add, "+", Normal, NULL }, 520 | { subt, "-", Normal, NULL }, 521 | { mult, "*", Normal, NULL }, 522 | { exponent, "^", Normal, NULL }, 523 | { divide, "/", Normal, NULL }, 524 | { modulo, "%", Normal, NULL }, 525 | { absolute, "abs", Normal, NULL }, 526 | { dotS, ".s", Normal, NULL }, 527 | { dot, ".", Normal, NULL }, 528 | { udot, "u.", Normal, NULL }, 529 | { bye, "bye", Normal, NULL }, 530 | { words, "words", Normal, NULL }, 531 | { rdepth, "rdepth", Normal, NULL }, 532 | { depth, "depth", Normal, NULL }, 533 | { dupe, "dup", Normal, NULL }, 534 | { qdupe, "?dup", Normal, NULL }, 535 | { rot, "rot", Normal, NULL }, 536 | { nip, "nip", Normal, NULL }, 537 | { tuck, "tuck", Normal, NULL }, 538 | { drop, "drop", Normal, NULL }, 539 | { over, "over", Normal, NULL }, 540 | { swap, "swap", Normal, NULL }, 541 | { pick, "pick", Normal, NULL }, 542 | { toR, ">r", Normal, NULL }, 543 | { Rto, "r>", Normal, NULL }, 544 | { Eof, inEOF, Normal, NULL }, 545 | { cells, "cells", Normal, NULL }, 546 | { cellsize, "cellsize", Normal, NULL }, 547 | { wrd_fetch, "@", Normal, NULL }, 548 | { wrd_store, "!", Normal, NULL }, 549 | { reg_fetch, "r@", Normal, NULL }, 550 | { reg_store, "r!", Normal, NULL }, 551 | { crg_fetch, "cr@", Normal, NULL }, 552 | { crg_store, "cr!", Normal, NULL }, 553 | { hlf_fetch, "h@", Normal, NULL }, 554 | { hlf_store, "h!", Normal, NULL }, 555 | { byt_fetch, "c@", Normal, NULL }, 556 | { byt_store, "c!", Normal, NULL }, 557 | { lft_shift, "<<", Normal, NULL }, 558 | { rgt_shift, ">>", Normal, NULL }, 559 | { cmove, "cmove", Normal, NULL }, 560 | { word, "word", Normal, NULL }, 561 | { ascii, "ascii", Immediate, NULL }, 562 | { q_key, "?key", Normal, NULL }, 563 | { key, "key", Normal, NULL }, 564 | { emit, "emit", Normal, NULL }, 565 | { type, "type", Normal, NULL }, 566 | { cr, "cr", Normal, NULL }, 567 | { dp, "dp", Normal, NULL }, 568 | { stringptr, "strings", Normal, NULL }, 569 | { flashsize, "flashsize", Normal, NULL }, 570 | { flashptr, "flash", Normal, NULL }, 571 | { here, "here", Normal, NULL }, 572 | { freespace, "freespace", Normal, NULL }, 573 | { comma, ",", Normal, NULL }, 574 | { doLiteral, "(literal)", Normal, NULL }, 575 | { colon, ":", Normal, NULL }, 576 | { semicolon, ";", Normal, NULL }, 577 | { execute, "execute", Normal, NULL }, 578 | { call, "call", Normal, NULL }, 579 | { doColon, "(colon)", Normal, NULL }, 580 | { tick, "'", Immediate, NULL }, 581 | { nfa, ">name", Normal, NULL }, 582 | { cfa, ">code", Normal, NULL }, 583 | { pfa, ">body", Normal, NULL }, 584 | { decimal, "decimal", Normal, NULL }, 585 | { hex, "hex", Normal, NULL }, 586 | { base, "base", Normal, NULL }, 587 | { trace, "trace", Normal, NULL }, 588 | { sigvar, "sigval", Normal, NULL }, 589 | { errvar, "err_var", Normal, NULL }, 590 | { errval, "err_val", Normal, NULL }, 591 | { errstr, "err_str", Normal, NULL }, 592 | { errmax, "err_max", Normal, NULL }, 593 | { resetter, "warm", Normal, NULL }, 594 | { cold, "cold", Normal, NULL }, 595 | { see, "see", Normal, NULL }, 596 | { pushPfa, "(variable)", Normal, NULL }, 597 | { allot, "allot", Normal, NULL }, 598 | { create, "create", Normal, NULL }, 599 | { lambda, "lambda", Normal, NULL }, // ( -- ) 600 | { does, "does>", Normal, NULL }, 601 | { constant, "constant", Normal, NULL }, 602 | { variable, "variable", Normal, NULL }, 603 | { normal, "normal", Normal, NULL }, 604 | { immediate, "immediate", Normal, NULL }, 605 | { imState, "[", Immediate, NULL }, 606 | { pvState, "]", Immediate, NULL }, 607 | { unresolved, "unresolved", Normal, NULL }, 608 | { fwd_mark, ">mark", Normal, NULL }, 609 | { fwd_resolve,">resolve", Normal, NULL }, 610 | { bkw_mark, "", Normal, NULL }, 625 | { ge, ">=", Normal, NULL }, 626 | { le, "<=", Normal, NULL }, 627 | { eq, "==", Normal, NULL }, 628 | { ne, "!=", Normal, NULL }, 629 | { And, "&", Normal, NULL }, 630 | { and, "and", Normal, NULL }, 631 | { or, "or", Normal, NULL }, 632 | { xor, "xor", Normal, NULL }, 633 | { not, "not", Normal, NULL }, 634 | { Buf, "buf", Normal, NULL }, 635 | { nBufs, "nbufs", Normal, NULL }, 636 | { Buf, "scratch", Normal, NULL }, 637 | { pad, "pad", Normal, NULL }, 638 | { comment, "(", Immediate, NULL }, 639 | { flushtoeol, "\\", Immediate, NULL }, 640 | { dotcomment, ".(", Immediate, NULL }, 641 | { quote, "\"", Immediate, NULL }, 642 | { dotquote, ".\"", Immediate, NULL }, 643 | { count, "count", Normal, NULL }, 644 | { ssave, "save", Normal, NULL }, 645 | { unssave, "unsave", Normal, NULL }, 646 | { infile, "infile", Normal, NULL }, 647 | { filename, "filename", Normal, NULL }, 648 | { outfile, "outfile", Normal, NULL }, 649 | { closeout, "closeout", Normal, NULL }, 650 | #ifdef HOSTED 651 | { isfile, "isfile", Normal, NULL }, 652 | { opentty, "opentty", Normal, NULL }, 653 | { closetty, "closetty", Normal, NULL }, 654 | { sndtty, "sndtty", Normal, NULL }, 655 | { waitrdy, "waitrdy", Normal, NULL }, 656 | { rcvtty, "rcvtty", Normal, NULL }, 657 | { qdlopen, "dlopen", Normal, NULL }, 658 | { qdlclose, "dlclose", Normal, NULL }, 659 | { qdlsym, "dlsym", Normal, NULL }, 660 | { qdlerror, "dlerror", Normal, NULL }, 661 | { last_will, "atexit", Normal, NULL }, 662 | { spinner, "spin", Normal, NULL }, 663 | { path, "path", Normal, NULL }, // ( -- ptr ) 664 | { it_set, "it_set", Normal, NULL }, 665 | { it_reset, "it_reset", Normal, NULL }, 666 | { it_doit, "it_doit", Normal, NULL }, 667 | #endif /* HOSTED */ 668 | { callout, "native", Normal, NULL }, 669 | { clkspersec, "clks", Normal, NULL }, 670 | { plusplus, "++", Normal, NULL }, 671 | { minusminus, "--", Normal, NULL }, 672 | { utime, "utime", Normal, NULL }, 673 | { ops, "ops", Normal, NULL }, 674 | { noops, "noops", Normal, NULL }, 675 | { qdo, "do", Immediate, NULL }, 676 | { do_do, "(do)", Normal, NULL }, 677 | { do_I, "i", Normal, NULL }, 678 | { loop, "loop", Immediate, NULL }, 679 | { do_loop, "(loop)", Normal, NULL }, 680 | { ploop, "+loop", Immediate, NULL }, 681 | { do_ploop, "(+loop)", Normal, NULL }, 682 | { forget, "forget", Normal, NULL }, 683 | { fmt_start, "<#", Normal, NULL }, 684 | { fmt_digit, "#", Normal, NULL }, 685 | { fmt_num, "#s", Normal, NULL }, 686 | { fmt_hold, "hold", Normal, NULL }, 687 | { fmt_sign, "sign", Normal, NULL }, 688 | { fmt_end, "#>", Normal, NULL }, 689 | { utf8_encode, "utf8", Normal, NULL }, // ( ch buf len -- len ) 690 | { accept, "accept", Normal, NULL }, // ( buf len -- n ) 691 | { find, "find", Normal, NULL }, // ( ptr -- dp | 0 ) 692 | { version, "version", Normal, NULL }, // ( -- Mjr Mnr Rev ) 693 | { code, "code", Normal, NULL }, // ( -- adr ) 694 | { data, "data", Normal, NULL }, // ( -- adr ) 695 | { align, "align", Normal, NULL }, // ( adr -- adr' ) 696 | { fill, "fill", Normal, NULL }, // ( adr -- adr' ) 697 | { NULL, NULL, 0, NULL } 698 | } ; 699 | 700 | Dict_t Colon_Defs[sz_ColonDefs] ; 701 | Cell_t n_ColonDefs = 0 ; 702 | 703 | Cell_t flash[sz_FLASH] = { FLASH_INIT_VAL } ; 704 | Cell_t *flash_mem = StartOf( flash ) ; 705 | 706 | // Some global state variables (see forget();) 707 | Cell_t *Here ; 708 | Cell_t *DictPtr ; 709 | Byt_t *String_Data = NULL ; 710 | Byt_t *String_LowWater = NULL ; 711 | Cell_t Base = 10 ; 712 | Cell_t Trace = 0 ; 713 | 714 | typedef enum { 715 | state_Interactive, 716 | state_Compiling, 717 | state_Interpret, 718 | state_Immediate, 719 | state_Undefined 720 | } State_t ; 721 | 722 | State_t state = state_Interactive ; 723 | State_t state_save = state_Interactive ; 724 | 725 | /* 726 | -- error codes and strings 727 | */ 728 | typedef enum { 729 | err_OK = 0, 730 | err_StackOvr, 731 | err_StackUdr, 732 | err_DivZero, 733 | err_NoInput, 734 | err_BadBase, 735 | err_BadLiteral, 736 | err_BufOvr, 737 | err_NullPtr, 738 | err_NoSpace, 739 | err_BadState, 740 | err_UnResolved, 741 | err_CaughtSignal, 742 | err_Unsave, 743 | err_NoWord, 744 | err_TknSize, 745 | err_SysCall, 746 | err_BadString, 747 | err_NoFile, 748 | err_InStack, 749 | err_Range, 750 | err_Undefined 751 | } Err_t ; 752 | 753 | Str_t errors[] = { 754 | "-- Not an error.", 755 | "-- Stack overflow.", 756 | "-- Stack underflow.", 757 | "-- Division by zero.", 758 | "-- No more input.", 759 | "-- Radix is out of range.", 760 | "-- Bad literal conversion.", 761 | "-- Buffer overflow.", 762 | "-- NULL pointer.", 763 | "-- Dictionary space exhausted.", 764 | "-- Bad state.", 765 | "-- Unresolved branch.", 766 | "-- Caught a signal.", 767 | "-- Too late to un-save.", 768 | "-- No such word exists.", 769 | "-- Tkn too large.", 770 | "-- System call glitch.", 771 | "-- Bad String.", 772 | "-- No file access.", 773 | "-- Input stack overflow.", 774 | "-- Range error.", 775 | "-- Undefined error.", 776 | NULL, 777 | } ; 778 | 779 | typedef enum { 780 | rst_unexpected = 0, 781 | rst_signalhdlr = 1, 782 | rst_catch = 2, 783 | rst_application = 3, 784 | rst_checkstack = 4, 785 | rst_coldstart = 5, 786 | rst_user = 6 787 | } check_pt ; 788 | 789 | Str_t resetfrom[] = { 790 | "unexpected", 791 | "sig_hdlr", 792 | "catch handler", 793 | "application", 794 | "checkstack", 795 | "cold start", 796 | "user", 797 | NULL 798 | } ; 799 | 800 | Wrd_t promptVal ; 801 | Str_t promptStr[] = { 802 | "ok ", 803 | "-- ", 804 | NULL 805 | } ; 806 | 807 | Str_t error_loc = (Str_t) NULL ; 808 | Err_t error_code = 0 ; 809 | Str_t digits = { "0123456789abcdefghijklmnopqrstuvwxyz" } ; 810 | 811 | /* 812 | -- string and character handling stuff which converts 813 | numbers, reads tokens and performs the platform 814 | specific I/O. 815 | */ 816 | 817 | void catch() ; 818 | void err_throw( Str_t f, Wrd_t l, Err_t e ) ; 819 | Wrd_t put_str( Str_t s ); 820 | Wrd_t get_str( Wrd_t fd, Str_t buf, Wrd_t len ); 821 | Wrd_t inp( Wrd_t fd, Str_t buf, Wrd_t len ); 822 | Wrd_t outp( Wrd_t fd, Str_t buf, Wrd_t len ); 823 | Wrd_t str_match( Str_t a, Str_t b, Wrd_t len ); 824 | Wrd_t str_length( Str_t str ); 825 | Wrd_t str_literal( Str_t tkn, Wrd_t radix ); 826 | Wrd_t str_format( Str_t dst, Wrd_t dlen, Str_t fmt, ... ); 827 | Wrd_t str_format_ap( Str_t dst, Wrd_t dlen, Str_t fmt, va_list ap ); 828 | void str_set( Str_t dst, Byt_t dat, Wrd_t len ); 829 | Wrd_t str_copy( Str_t dst, Str_t src, Wrd_t len ); 830 | Wrd_t str_utoa( uByt_t *dst, Wrd_t dlen, Cell_t val, Wrd_t radix ); 831 | Wrd_t str_ntoa( Str_t dst, Wrd_t dlen, Cell_t val, Wrd_t radix, Wrd_t isSigned ); 832 | Str_t str_token( Input_t *inptr ); 833 | Str_t str_delimited( Str_t term ) ; 834 | Str_t str_cache( Str_t tag ); 835 | Str_t str_seal( void ); 836 | Str_t str_uncache( Str_t tag ); 837 | Wrd_t ch_matches( Byt_t ch, Str_t anyOf ); 838 | Byt_t ch_tolower( Byt_t b ); 839 | Wrd_t utf8_encoder( Wrd_t ch, Str_t buf, Wrd_t len ); 840 | Wrd_t ch_index( Str_t str, Byt_t c ); 841 | void sig_hdlr( int sig ); 842 | Wrd_t io_cbreak( int fd ); 843 | Wrd_t fmt_out( Str_t fmt, ... ); 844 | 845 | #ifdef HOSTED 846 | 847 | void sig_hdlr( int sig ){ 848 | sigval = sig ; 849 | throw( err_CaughtSignal ) ; 850 | // if( sigval == SIGSEGV ){ 851 | // catch(); 852 | // } 853 | catch() ; 854 | return ; 855 | } 856 | 857 | Str_t in_File = (Str_t) NULL ; 858 | Str_t in_Word = (Str_t) NULL ; 859 | Cell_t quiet = 0 ; 860 | Dict_t *lookup( Str_t tkn ); 861 | static int do_x_Once = 1 ; 862 | 863 | void usage(int argc, char **argv ) 864 | { 865 | Wrd_t nx ; 866 | nx = fmt_out( "usage:\n\t%s [-i ] [-q] [-x ]\n\n", argv[0] ) ; 867 | } 868 | 869 | #define STD_ARGS "i:x:qt" 870 | void chk_args( int argc, char **argv ) 871 | { 872 | int ch, err=0 ; 873 | while( (ch = getopt( argc, argv, STD_ARGS )) != -1 ) 874 | { 875 | switch( ch ) 876 | { 877 | case 'i': 878 | in_File = str_cache( optarg ) ; 879 | break ; 880 | case 'x': 881 | in_Word = str_cache( optarg ) ; 882 | break ; 883 | case 'q': 884 | quiet++ ; 885 | break ; 886 | case 't': 887 | push( 1 ); 888 | trace() ; 889 | wrd_store(); 890 | break ; 891 | default: 892 | err++ ; 893 | } 894 | } 895 | if( err ) 896 | { 897 | usage( argc, argv ); 898 | exit( 1 ); 899 | } 900 | return ; 901 | } 902 | 903 | #endif // HOSTED 904 | 905 | Str_t Locale = (Str_t) NULL ; 906 | Byt_t found_eol = (Byt_t) 0 ; 907 | 908 | // reset never forgets ... 909 | // forget does that (see below). 910 | void q_reset() 911 | { 912 | 913 | #ifdef HOSTED 914 | sigval = 0 ; 915 | signal( SIGINT, sig_hdlr ) ; 916 | #ifndef __WIN32__ 917 | signal( SIGQUIT, sig_hdlr ) ; 918 | signal( SIGHUP, sig_hdlr ) ; 919 | signal( SIGKILL, sig_hdlr ) ; 920 | signal( SIGBUS, sig_hdlr ) ; 921 | signal( SIGFPE, sig_hdlr ) ; 922 | signal( SIGSEGV, sig_hdlr ) ; 923 | #endif 924 | #endif 925 | 926 | decimal() ; 927 | promptVal = 0 ; 928 | 929 | tos = (Cell_t *) StartOf( stack ) ; 930 | *tos = FLASH_INIT_VAL ; 931 | 932 | rtos = (Cell_t *) StartOf( rstack ) ; 933 | *rtos = FLASH_INIT_VAL ; 934 | 935 | error_code = err_OK ; 936 | state = state_Interactive ; 937 | 938 | } 939 | 940 | /* 941 | -- innards of the `machine'. 942 | */ 943 | #ifdef NATIVE 944 | 945 | void tracker( const char *F, int L ); 946 | void raise(){tracker((const char *) __FUNCTION__, __LINE__);} 947 | 948 | #define x_UART_BASE 0x101F1000UL 949 | #define x_UARTDR (x_UART_BASE+0x000) 950 | #define x_UARTFR (x_UART_BASE+0x018) 951 | volatile unsigned int * const UARTDR = (unsigned int *)0x101f1000; // UART0 data register 952 | volatile unsigned int * const UARTFR = (unsigned int *)0x101f1018; // UART0 flag register 953 | volatile unsigned int * const UARTCR = (unsigned int *)0x101f1030; // UART0 control register 954 | volatile unsigned int * const UARTLCR_H = (unsigned int *)0x101f102c; // UART0 line control register 955 | 956 | 957 | // defined in the assembler file ... 958 | int GET8( unsigned adr ); 959 | int GET32( unsigned adr ); 960 | int PUT32( unsigned adr, unsigned char ch ); 961 | 962 | void uart_putc ( unsigned int c ) 963 | { 964 | while( ( *(UARTFR) & 0x20 ) != 0 ); 965 | *(UARTDR) = c & 0xff ; 966 | } 967 | 968 | Cell_t uart_getc_ne( void ) 969 | { 970 | int ch ; 971 | while ( *(UARTFR) == 0x90 ) ; 972 | 973 | ch = *(UARTDR) ; 974 | return ch ; 975 | } 976 | 977 | Cell_t uart_getc( void ) 978 | { 979 | int ch ; 980 | while ( *(UARTFR) == 0x90 ) ; 981 | 982 | ch = *(UARTDR) ; 983 | uart_putc( ch ) ; 984 | return ch ; 985 | } 986 | 987 | int uart_can_recv( void ) 988 | { 989 | if( (*UARTFR) == 0x90 ) 990 | return( 0 ); 991 | 992 | return( 1 ); 993 | } 994 | 995 | void uart_init(void) 996 | { 997 | // GET32( x_UARTDR ); 998 | return; 999 | } 1000 | 1001 | int notmain( void ) 1002 | { 1003 | uart_init(); 1004 | 1005 | #else // NATIVE vs HOSTED ... 1006 | 1007 | int main( int argc, char **argv ) 1008 | { 1009 | 1010 | #endif 1011 | 1012 | forget() ; // puts the system in a known state ... 1013 | q_reset() ; 1014 | push( "stdin" ) ; 1015 | infile() ; 1016 | 1017 | #ifdef HOSTED 1018 | Locale = str_cache( (Str_t) setlocale( LC_ALL, "" ) ) ; 1019 | off_path = str_cache( getenv( OFF_PATH ) ) ; 1020 | chk_args( argc, argv ) ; 1021 | if( !isNul( in_File ) ) 1022 | { 1023 | push( (Str_t) in_File ); 1024 | infile() ; 1025 | } 1026 | if( !isNul( in_Word ) ) 1027 | { 1028 | // quiet++ ; 1029 | do_x_Once = 0 ; 1030 | push( (Cell_t) lookup( in_Word ) ) ; 1031 | execute() ; 1032 | } 1033 | #else 1034 | Locale = str_cache( "EMBEDDED" ) ; 1035 | #endif 1036 | 1037 | str_seal() ; 1038 | banner() ; 1039 | quit() ; 1040 | return 0 ; 1041 | } 1042 | 1043 | Wrd_t ch_matches( Byt_t ch, Str_t anyOf ) 1044 | { 1045 | Str_t p ; 1046 | 1047 | p = (Str_t) StartOf( anyOf ) ; 1048 | while( *p ){ 1049 | if( ch == *(p++) ){ 1050 | return 1 ; 1051 | } 1052 | } 1053 | return 0 ; 1054 | } 1055 | 1056 | Byt_t ch_tolower( Byt_t b ) 1057 | { 1058 | if( b <= 'Z' && b >= 'A' ){ 1059 | return b ^ 0x20 ; 1060 | } 1061 | return b & 0xFF ; 1062 | } 1063 | 1064 | Wrd_t utf8_encoder( Wrd_t ch, Str_t buf, Wrd_t len ) 1065 | { 1066 | 1067 | str_set( buf, 0, len ) ; 1068 | if (ch < 0x80) { 1069 | buf[0] = (char)ch; 1070 | return( 1 ) ; 1071 | } 1072 | 1073 | if (ch < 0x800) { 1074 | buf[0] = (ch>>6) | 0xC0; 1075 | buf[1] = (ch & 0x3F) | 0x80; 1076 | return( 2 ) ; 1077 | } 1078 | 1079 | if (ch < 0x10000) { 1080 | buf[0] = (ch>>12) | 0xE0; 1081 | buf[1] = ((ch>>6) & 0x3F) | 0x80; 1082 | buf[2] = (ch & 0x3F) | 0x80; 1083 | return( 3 ); 1084 | } 1085 | 1086 | if (ch < 0x110000) { 1087 | buf[0] = (ch>>18) | 0xF0; 1088 | buf[1] = ((ch>>12) & 0x3F) | 0x80; 1089 | buf[2] = ((ch>>6) & 0x3F) | 0x80; 1090 | buf[3] = (ch & 0x3F) | 0x80; 1091 | return( 4 ) ; 1092 | } 1093 | 1094 | return( 0 ) ; 1095 | } 1096 | 1097 | Wrd_t ch_index( Str_t str, Byt_t c ) 1098 | { 1099 | Byt_t *p, *start ; 1100 | 1101 | p = start = (Byt_t *) StartOf( str ) ; 1102 | while( *p ){ 1103 | if( *p == c ){ 1104 | return p - start ; 1105 | } 1106 | p++ ; 1107 | } 1108 | return -1; 1109 | } 1110 | 1111 | Str_t str_token( Input_t *input ) 1112 | { 1113 | int tkn = 0 ; 1114 | Byt_t this_char ; 1115 | static Byt_t acc[sz_INBUF] ; 1116 | 1117 | found_eol = (Byt_t) 0 ; 1118 | do { 1119 | if( input->bytes_read < 1 ) 1120 | { 1121 | prompt() ; 1122 | str_set( input->bytes, 0, sz_INBUF ) ; 1123 | input->bytes_read = inp( INPUT, input->bytes, sz_INBUF ) ; 1124 | if( input->bytes_read == 0 ) 1125 | { 1126 | input->bytes[0] = (Byt_t) 0 ; 1127 | return inEOF ; 1128 | } 1129 | input->bytes_this = 0 ; 1130 | continue ; 1131 | } 1132 | 1133 | if( input->bytes_this > (input->bytes_read - 1) ) 1134 | { 1135 | input->bytes_this = input->bytes_read = -1 ; 1136 | continue ; 1137 | } 1138 | 1139 | 1140 | // accumulate printing characters in the accumulater for the next token ... 1141 | this_char = input->bytes[input->bytes_this++] ; 1142 | 1143 | if( !ch_matches( this_char, WHITE_SPACE ) ) 1144 | { 1145 | acc[tkn++] = this_char ; 1146 | acc[tkn] = (Byt_t) 0 ; 1147 | continue ; 1148 | } 1149 | 1150 | // errors and comments require eol, so flag it in a global. 1151 | if( ch_matches( this_char, EOL ) ) 1152 | { 1153 | input->in_line++ ; 1154 | found_eol = this_char ; 1155 | } 1156 | 1157 | // have a token, return the accumulator ... 1158 | if( tkn > 0 ) 1159 | { 1160 | return (Str_t) acc ; 1161 | } 1162 | 1163 | // null tokens are simply ignored ... 1164 | if( found_eol ) 1165 | { 1166 | return (Str_t) NULL ; 1167 | } 1168 | 1169 | } while( 1 ) ; 1170 | } 1171 | 1172 | Wrd_t str_match( Str_t a, Str_t b, Wrd_t len ) 1173 | { 1174 | int8_t i ; 1175 | 1176 | if( (str_length( a ) == len) && (str_length( b ) == len) ){ 1177 | for( i = 0 ; i < len ; i++ ){ 1178 | if( a[i] != b[i] ){ 1179 | return 0 ; 1180 | } 1181 | } 1182 | return 1 ; 1183 | } 1184 | return 0 ; 1185 | } 1186 | 1187 | Wrd_t str_length( Str_t str ) 1188 | { 1189 | Str_t p ; 1190 | Wrd_t ret = 0 ; 1191 | 1192 | if( isNul( str ) ){ 1193 | return 0 ; 1194 | } 1195 | 1196 | p = str ; 1197 | while( *p++ ) ret++ ; 1198 | return ret ; 1199 | } 1200 | 1201 | Wrd_t str_literal( Str_t tkn, Wrd_t radix ) 1202 | { 1203 | Wrd_t ret, sign, digit, base ; 1204 | Str_t p ; 1205 | 1206 | if( radix > str_length( digits ) ){ 1207 | put_str( tkn ) ; 1208 | throw( err_BadBase ) ; 1209 | return -1 ; 1210 | } 1211 | 1212 | sign = 1 ; 1213 | base = radix ; 1214 | p = tkn ; 1215 | switch( *p++ ){ 1216 | case '-': /* negative */ 1217 | sign = -1 ; 1218 | break ; 1219 | case '+': /* positive */ 1220 | sign = 1 ; 1221 | break ; 1222 | case '$': /* hex constant */ 1223 | base = 16 ; 1224 | break ; 1225 | case '0': /* octal or hex constant */ 1226 | base = 8 ; 1227 | if( *p == 'x' || *p == 'X' ){ 1228 | base = 16 ; 1229 | p++ ; 1230 | } 1231 | break ; 1232 | default: /* none of the above ... start over */ 1233 | p = tkn ; 1234 | break ; 1235 | } 1236 | 1237 | ret = 0 ; 1238 | while( *p ){ 1239 | digit = ch_index( digits, ch_tolower( *p++ ) ) ; 1240 | if( digit < 0 || digit > (base - 1) ){ 1241 | fmt_out( "-- %s digit: '%x'\n", tkn, digit ) ; 1242 | throw( err_BadLiteral ) ; 1243 | return -1 ; 1244 | } 1245 | ret *= base ; 1246 | ret += digit ; 1247 | } 1248 | ret *= sign ; 1249 | return ret ; 1250 | } 1251 | 1252 | void str_set( Str_t dst, Byt_t dat, Wrd_t len ) 1253 | { 1254 | Str_t ptr ; 1255 | 1256 | for( ptr = dst ; ptr - dst < len ; ptr++ ){ 1257 | *ptr = (Byt_t) dat & 0xff ; 1258 | } 1259 | } 1260 | 1261 | Wrd_t str_copy( Str_t dst, Str_t src, Wrd_t len ) 1262 | { 1263 | Wrd_t i ; 1264 | Str_t from, to ; 1265 | 1266 | to = dst ; 1267 | from = src ; 1268 | for( i = 0 ; i < len ; i++ ){ 1269 | *to++ = *from++ ; 1270 | } 1271 | return i ; 1272 | } 1273 | 1274 | Wrd_t str_utoa( uByt_t *dst, Wrd_t dlen, Cell_t val, Wrd_t radix ) 1275 | { 1276 | 1277 | uCell_t n, i, dig ; 1278 | uByt_t *p, *q, buf[30] ; 1279 | 1280 | i = 0 ; 1281 | n = val ; 1282 | do{ 1283 | dig = (n % radix) + '0' ; 1284 | dig = (dig > '9') ? dig - '9' + 'a' - 1 : dig ; 1285 | buf[i++] = dig ; 1286 | n /= radix ; 1287 | } while( n != 0 ) ; 1288 | buf[i] = (Byt_t) 0 ; 1289 | 1290 | n = 0 ; 1291 | p = dst ; 1292 | q = &buf[i] ; 1293 | do { 1294 | if( n > dlen ){ 1295 | throw( err_BufOvr ) ; 1296 | return -1 ; 1297 | } 1298 | *p++ = *q-- ; n++ ; 1299 | } while( q >= &buf[0] ); 1300 | *p++ = (Byt_t) 0 ; 1301 | 1302 | return n ; 1303 | } 1304 | Wrd_t str_ntoa( Str_t dst, Wrd_t dlen, Cell_t val, Wrd_t radix, Wrd_t isSigned ) 1305 | { 1306 | Wrd_t i, sign, n ; 1307 | Byt_t c, buf[30] ; 1308 | Str_t p ; 1309 | 1310 | n = val ; 1311 | sign = (Byt_t) 0 ; 1312 | if( isSigned && val < 0 ){ 1313 | sign = '-' ; 1314 | n = -1 * n ; 1315 | } 1316 | 1317 | i = 0 ; 1318 | do { 1319 | c = '0' + (n % radix) ; 1320 | c = (c > '9') ? c - '9' + 'a' - 1 : c ; 1321 | buf[i++] = c ; 1322 | n /= radix ; 1323 | } while( n != 0 ) ; 1324 | 1325 | buf[ i ] = ' ' ; 1326 | if( sign ){ 1327 | buf[i] = sign ; 1328 | } 1329 | 1330 | if( i > dlen ){ 1331 | throw( err_BufOvr ) ; 1332 | return -1 ; 1333 | } 1334 | 1335 | if( !sign ){ 1336 | i-- ; 1337 | } 1338 | n = i + 1 ; 1339 | p = dst ; 1340 | do { 1341 | *p++ = buf[i--] ; 1342 | } while( i > -1 ) ; 1343 | *p++ = (Byt_t) 0 ; 1344 | return n ; 1345 | } 1346 | 1347 | Wrd_t str_format( Str_t dst, Wrd_t dlen, Str_t fmt, ... ) 1348 | { 1349 | Wrd_t rv ; 1350 | va_list ap ; 1351 | 1352 | va_start( ap, fmt ); 1353 | rv = str_format_ap( dst, dlen, fmt, ap ) ; 1354 | va_end( ap ) ; 1355 | return rv ; 1356 | } 1357 | 1358 | Wrd_t str_format_ap( Str_t dst, Wrd_t dlen, Str_t fmt, va_list ap ) 1359 | { 1360 | va_list ap2 ; 1361 | Str_t p_fmt, p_dst, p_end, str ; 1362 | Byt_t ch ; 1363 | Wrd_t cell ; 1364 | 1365 | p_end = dst + dlen ; 1366 | p_dst = dst ; 1367 | p_fmt = fmt ; 1368 | 1369 | va_copy( ap2, ap ); 1370 | while( (ch = *(p_fmt++)) && (p_dst < p_end) ){ 1371 | if( ch == '%' ){ 1372 | ch = *(p_fmt++) ; 1373 | switch( ch ){ 1374 | case '%': // %% 1375 | *p_dst++ = ch & 0xff ; 1376 | break ; 1377 | case 'c': // %c 1378 | ch = va_arg( ap2, int ); 1379 | *p_dst++ = ch & 0xff ; 1380 | break ; 1381 | case 's': // %s 1382 | str = va_arg( ap2, Str_t ); 1383 | p_dst += str_copy( p_dst, str, str_length( str ) ) ; 1384 | break ; 1385 | case 'l': // %l 1386 | ch = *(p_fmt++) ; 1387 | case 'd': // %d 1388 | cell = va_arg( ap2, Cell_t ) ; 1389 | p_dst += str_ntoa( p_dst, dlen - (p_dst - dst) - 1, cell, Base, 1 ) ; 1390 | break ; 1391 | case 'x': // %x 1392 | cell = va_arg( ap2, Cell_t ) ; 1393 | p_dst += str_ntoa( p_dst, dlen - (p_dst - dst) - 1, cell, 16, 0 ) ; 1394 | break ; 1395 | case 'o': // %o 1396 | cell = va_arg( ap2, Cell_t ) ; 1397 | p_dst += str_ntoa( p_dst, dlen - (p_dst - dst) - 1, cell, 8, 0 ) ; 1398 | break ; 1399 | case 'u': // %u 1400 | cell = va_arg( ap2, uCell_t ) ; 1401 | p_dst += str_utoa( (uByt_t *) p_dst, dlen - (p_dst - dst) - 1, (uCell_t) cell, Base ) ; 1402 | break ; 1403 | default: 1404 | break ; 1405 | } 1406 | } else { 1407 | *p_dst++ = ch ; 1408 | } 1409 | } 1410 | if( !isNul( p_dst ) && p_dst < p_end ) 1411 | { 1412 | *p_dst++ = (Byt_t) 0 ; 1413 | } 1414 | return p_dst - dst - 1 ; 1415 | } 1416 | 1417 | Str_t str_uncache( Str_t tag ) 1418 | { 1419 | Cell_t len ; 1420 | 1421 | len = str_length( tag ) + 1 ; 1422 | String_Data += len ; 1423 | return (Str_t) String_Data ; 1424 | } 1425 | 1426 | Str_t str_cache( Str_t s ) 1427 | { 1428 | 1429 | Cell_t len ; 1430 | 1431 | if( !isNul( s ) ) 1432 | { 1433 | len = str_length( s ) + 1; 1434 | String_Data -= len ; 1435 | str_copy( (Str_t) String_Data, s, len ) ; 1436 | } 1437 | return (Str_t) String_Data ; 1438 | } 1439 | 1440 | Str_t str_seal( void ) 1441 | { 1442 | String_LowWater = String_Data ; 1443 | return (Str_t) String_Data ; 1444 | } 1445 | 1446 | Dict_t *lookup( Str_t tkn ) 1447 | { 1448 | Dict_t *p ; 1449 | Cell_t i ; 1450 | 1451 | if( !isNul( tkn ) ) 1452 | { 1453 | if( n_ColonDefs > 0 ) 1454 | { 1455 | for( i = n_ColonDefs - 1 ; i > -1 ; i-- ) 1456 | { 1457 | p = &Colon_Defs[ i ] ; 1458 | if( isMatch( tkn, p ->nfa ) ) 1459 | { 1460 | return p ; 1461 | } 1462 | } 1463 | } 1464 | 1465 | p = StartOf( Primitives ) ; 1466 | while( p ->nfa ) 1467 | { 1468 | if( isMatch( tkn, p ->nfa ) ) 1469 | { 1470 | return p ; 1471 | } 1472 | p++ ; 1473 | } 1474 | 1475 | } 1476 | return (Dict_t *) NULL ; 1477 | 1478 | } 1479 | 1480 | /* 1481 | -- Forth primitives ... 1482 | for visibility within the interpreter, they 1483 | must be pre-declared, and placed in the Primitive[] 1484 | dictionary structure above ... 1485 | */ 1486 | 1487 | void quit() 1488 | { 1489 | Str_t tkn ; 1490 | Dict_t *dp ; 1491 | 1492 | #ifdef HOSTED 1493 | Wrd_t beenhere = 0, n ; 1494 | beenhere = setjmp( env ) ; 1495 | if( beenhere > 0 ){ 1496 | catch(); 1497 | n = fmt_out( "-- Reset by %s.\n", resetfrom[beenhere] ) ; 1498 | if( beenhere == rst_coldstart ) 1499 | banner() ; 1500 | } 1501 | #endif 1502 | for(;;){ // *outer loop* 1503 | while( (tkn = str_token( &InputStack[in_This] )) ){ 1504 | dp = lookup( tkn ); 1505 | if( isNul( dp ) ){ 1506 | push( str_literal( tkn, Base ) ) ; 1507 | } else { 1508 | push( (Cell_t) dp ) ; 1509 | execute() ; 1510 | } 1511 | catch() ; 1512 | } // *tkn* 1513 | } // *ever* 1514 | } // *quit* 1515 | 1516 | void banner() 1517 | { 1518 | Wrd_t UNUSED( n ); 1519 | 1520 | #ifdef HOSTED 1521 | if( quiet ) return ; 1522 | #endif 1523 | 1524 | n = fmt_out( "-- OneFileForth-%s alpha Version: %s.%s.%s%c (%s)\n", FLAVOUR, MAJOR, MINOR, REVISION, dbg, Locale ) ; 1525 | n = fmt_out( "-- www.ControlQ.com\n\n" ) ; 1526 | } 1527 | 1528 | void tracker( const char *fun, int line ) 1529 | { 1530 | Wrd_t UNUSED( n ); 1531 | 1532 | n = fmt_out( "-- %s: %d\n", fun, line ) ; 1533 | } 1534 | 1535 | void prompt() 1536 | { 1537 | if( INPUT == 0 ){ 1538 | outp( OUTPUT, (Str_t) promptStr[promptVal], 3 ) ; 1539 | } 1540 | } 1541 | 1542 | void add() 1543 | { 1544 | register Cell_t n ; 1545 | 1546 | chk( 2 ) ; 1547 | n = pop() ; 1548 | *tos += n ; 1549 | } 1550 | 1551 | void subt() 1552 | { 1553 | register Cell_t n ; 1554 | 1555 | chk( 2 ) ; 1556 | n = pop() ; 1557 | *tos -= n ; 1558 | } 1559 | 1560 | void mult() 1561 | { 1562 | register Cell_t n ; 1563 | 1564 | chk( 2 ) ; 1565 | n = pop() ; 1566 | *tos *= n ; 1567 | } 1568 | 1569 | void exponent() 1570 | { 1571 | register Cell_t n, exp ; 1572 | 1573 | chk( 2 ) ; 1574 | n = pop() ; 1575 | exp = *tos; 1576 | *tos = 1 ; 1577 | for( ; n > 0 ; n-- ){ 1578 | *tos *= exp ; 1579 | } 1580 | } 1581 | 1582 | void divide() 1583 | { 1584 | register Cell_t n ; 1585 | 1586 | chk( 2 ) ; 1587 | n = pop(); 1588 | if( n == 0 ){ 1589 | throw( err_DivZero ) ; 1590 | return ; 1591 | } 1592 | *tos /= n ; 1593 | } 1594 | 1595 | void modulo() 1596 | { 1597 | register Cell_t n ; 1598 | 1599 | chk( 2 ) ; 1600 | n = pop(); 1601 | if( n == 0 ){ 1602 | throw( err_DivZero ) ; 1603 | return ; 1604 | } 1605 | *tos %= n ; 1606 | } 1607 | 1608 | void absolute() // -n -- n 1609 | { 1610 | *tos = Abs( *tos ) ; 1611 | } 1612 | 1613 | void dotS() 1614 | { 1615 | Cell_t i, num ; 1616 | 1617 | chk( 0 ) ; 1618 | depth() ; num = *tos ; dot() ; 1619 | put_str( " : " ) ; 1620 | for( i = 1; i <= num ; i++ ) 1621 | { 1622 | push( stack[i] ) ; dot() ; 1623 | } 1624 | } 1625 | 1626 | void dot() 1627 | { 1628 | Wrd_t n, val ; 1629 | Str_t buf = tb_get( TB ); 1630 | 1631 | chk( 1 ) ; 1632 | val = pop() ; 1633 | n = str_format( buf, tb_bufsize( TB ), "%d ", val ) ; 1634 | outp( OUTPUT, buf, n ) ; 1635 | } 1636 | 1637 | void udot() 1638 | { 1639 | Wrd_t UNUSED( n ); 1640 | Str_t buf = tb_get( TB ); 1641 | 1642 | chk( 1 ) ; 1643 | n = str_format( buf, tb_bufsize( TB ), "%u ", (uCell_t) pop() ) ; 1644 | outp( OUTPUT, buf, n ) ; 1645 | } 1646 | 1647 | void bye() 1648 | { 1649 | #ifdef HOSTED 1650 | exit( error_code ) ; 1651 | #endif 1652 | } 1653 | 1654 | void words() 1655 | { 1656 | Dict_t *p ; 1657 | Cell_t i, llen, wlen, nwords ; 1658 | 1659 | llen = 0 ; 1660 | nwords = 0 ; 1661 | if( n_ColonDefs > 0 ) 1662 | { 1663 | p = StartOf( Colon_Defs ) ; 1664 | for( i = n_ColonDefs - 1 ; i > -1 ; i-- ){ 1665 | p = &Colon_Defs[i] ; 1666 | wlen = str_length( p ->nfa ) ; 1667 | if( (llen + wlen) > 72 ) 1668 | { 1669 | fmt_out( "\n" ); 1670 | llen = 0 ; 1671 | } 1672 | llen += wlen ; 1673 | fmt_out( "%s ", p ->nfa ) ; 1674 | nwords++ ; 1675 | } 1676 | } 1677 | 1678 | p = StartOf( Primitives ) ; 1679 | while( p ->nfa ) 1680 | { 1681 | wlen = str_length( p ->nfa ) ; 1682 | if( (llen + wlen) > 72 ) 1683 | { 1684 | fmt_out( "\n" ); 1685 | llen = 0 ; 1686 | } 1687 | llen += wlen ; 1688 | fmt_out( "%s ", p ->nfa ) ; 1689 | nwords++ ; 1690 | p++ ; 1691 | } 1692 | fmt_out( "\n -- %d words.\n", nwords ); 1693 | } 1694 | 1695 | Wrd_t checkstack( Wrd_t n, Str_t fun ) 1696 | { 1697 | Wrd_t UNUSED( x ), d ; 1698 | 1699 | if( n > 0 ) { 1700 | depth(); d = pop() ; 1701 | if( d < n ){ 1702 | x = fmt_out( "-- Found %d of %d args expected in '%s'.\n", d, n, fun ) ; 1703 | throw( err_StackUdr ) ; 1704 | #ifdef HOSTED 1705 | longjmp( env, rst_checkstack ) ; 1706 | #endif 1707 | } 1708 | return 1 ; 1709 | } 1710 | 1711 | if( tos < (Cell_t *) StartOf( stack ) ){ 1712 | put_str( fun ) ; 1713 | throw( err_StackUdr ) ; 1714 | return 0 ; 1715 | } 1716 | 1717 | if( tos > &stack[sz_STACK] ){ 1718 | put_str( fun ) ; 1719 | throw( err_StackOvr ) ; 1720 | return 0 ; 1721 | } 1722 | return 1 ; 1723 | } 1724 | 1725 | void unresolved() 1726 | { 1727 | throw( err_UnResolved ) ; 1728 | } 1729 | 1730 | void fwd_mark() 1731 | { 1732 | push( (Cell_t) Here ) ; 1733 | push( (Cell_t) lookup( "unresolved" ) ) ; 1734 | comma() ; 1735 | } 1736 | 1737 | void fwd_resolve() 1738 | { 1739 | Cell_t *p ; 1740 | 1741 | p = (Cell_t *) pop() ; 1742 | *p = (Cell_t) Here ; 1743 | } 1744 | 1745 | void bkw_mark() 1746 | { 1747 | push( (Cell_t) Here ) ; 1748 | } 1749 | 1750 | void bkw_resolve() 1751 | { 1752 | comma() ; 1753 | } 1754 | 1755 | void begin() 1756 | { 1757 | bkw_mark(); 1758 | } 1759 | 1760 | void again() 1761 | { 1762 | push( (Cell_t) lookup( "branch" ) ) ; 1763 | comma() ; 1764 | bkw_resolve(); 1765 | } 1766 | 1767 | void While() 1768 | { 1769 | push( (Cell_t) lookup( "?branch" ) ); 1770 | comma() ; 1771 | fwd_mark(); 1772 | swap(); 1773 | } 1774 | 1775 | void Repeat() 1776 | { 1777 | push( (Cell_t) lookup( "branch" ) ); 1778 | comma() ; 1779 | bkw_resolve(); 1780 | fwd_resolve(); 1781 | } 1782 | 1783 | void Leave() 1784 | { 1785 | if( rtos > rstack ) 1786 | *rtos = 0 ; 1787 | } 1788 | 1789 | void Until() 1790 | { 1791 | push( (Cell_t) lookup( "?branch" ) ); 1792 | comma() ; 1793 | bkw_resolve() ; 1794 | } 1795 | 1796 | void If() 1797 | { 1798 | push( (Cell_t) lookup( "?branch" ) ) ; 1799 | comma() ; 1800 | fwd_mark() ; 1801 | } 1802 | 1803 | void Else() 1804 | { 1805 | push( (Cell_t) lookup( "branch" ) ) ; 1806 | comma(); 1807 | fwd_mark() ; 1808 | swap() ; 1809 | fwd_resolve() ; 1810 | } 1811 | 1812 | void Then() 1813 | { 1814 | fwd_resolve() ; 1815 | } 1816 | 1817 | void lt() 1818 | { 1819 | register Cell_t n ; 1820 | 1821 | chk( 2 ) ; 1822 | n = pop() ; 1823 | *tos = (*tos < n) ? 1 : 0 ; 1824 | } 1825 | 1826 | void gt() 1827 | { 1828 | register Cell_t n ; 1829 | 1830 | chk( 2 ) ; 1831 | n = pop() ; 1832 | *tos = (*tos > n) ? 1 : 0 ; 1833 | } 1834 | 1835 | void ge() 1836 | { 1837 | register Cell_t n ; 1838 | 1839 | chk( 2 ) ; 1840 | n = pop() ; 1841 | *tos = (*tos >= n) ? 1 : 0 ; 1842 | } 1843 | 1844 | void ne() 1845 | { 1846 | register Cell_t n ; 1847 | 1848 | chk( 2 ) ; 1849 | n = pop() ; 1850 | *tos = (*tos != n) ? 1 : 0 ; 1851 | } 1852 | 1853 | void eq() 1854 | { 1855 | register Cell_t n ; 1856 | 1857 | chk( 2 ) ; 1858 | n = pop() ; 1859 | *tos = (*tos == n) ? 1 : 0 ; 1860 | } 1861 | 1862 | void le() 1863 | { 1864 | register Cell_t n ; 1865 | 1866 | chk( 2 ) ; 1867 | n = pop() ; 1868 | *tos = (*tos <= n) ? 1 : 0 ; 1869 | } 1870 | 1871 | void And() 1872 | { 1873 | register Cell_t n ; 1874 | 1875 | chk( 2 ) ; 1876 | n = pop() ; 1877 | *tos &= n ; 1878 | } 1879 | 1880 | void and() 1881 | { 1882 | register Cell_t n ; 1883 | 1884 | chk( 2 ) ; 1885 | n = pop() ; 1886 | *tos = *tos && n ; 1887 | } 1888 | 1889 | void or() 1890 | { 1891 | register Cell_t n ; 1892 | 1893 | chk( 2 ) ; 1894 | n = pop() ; 1895 | *tos |= n ; 1896 | } 1897 | 1898 | void xor() 1899 | { 1900 | register Cell_t n ; 1901 | 1902 | chk( 2 ) ; 1903 | n = pop() ; 1904 | *tos ^= n ; 1905 | } 1906 | 1907 | void not() 1908 | { 1909 | 1910 | chk( 1 ) ; 1911 | *tos = ~(*tos) ; 1912 | } 1913 | 1914 | void q_branch() 1915 | { 1916 | Cell_t *ptr ; 1917 | 1918 | ptr = (Cell_t *) rpop() ; // grab next word pointer 1919 | if( pop() ){ // if .T. skip current pointer for next (?branch) 1920 | rpush( (Cell_t) ++ptr ) ; 1921 | return ; 1922 | } 1923 | rpush( *ptr ) ; // else branch to ptr ... 1924 | } 1925 | 1926 | void branch() 1927 | { 1928 | Cell_t *x ; 1929 | 1930 | x = (Cell_t *) rpop() ; // always branch to next ... 1931 | rpush( *x ) ; 1932 | } 1933 | 1934 | void rdepth() 1935 | { 1936 | Cell_t d ; 1937 | 1938 | d = rtos - StartOf( rstack ) ; 1939 | push( d ) ; 1940 | } 1941 | 1942 | void depth() 1943 | { 1944 | Cell_t d ; 1945 | 1946 | d = tos - StartOf( stack ) ; 1947 | push( d ) ; 1948 | } 1949 | 1950 | void dupe() // n1 -- n1 n1 1951 | { 1952 | register Cell_t n ; 1953 | 1954 | chk( 1 ) ; 1955 | n = *tos; 1956 | push( n ) ; 1957 | } 1958 | 1959 | void qdupe() // n1 != 0 ? -- n1 n1 : n1 1960 | { 1961 | register Cell_t n ; 1962 | 1963 | chk( 1 ) ; 1964 | if ( *tos ) 1965 | { 1966 | n = *tos; 1967 | push( n ) ; 1968 | } 1969 | } 1970 | 1971 | void rot() // n1 n2 n3 -- n2 n3 n1 1972 | { 1973 | register Cell_t n ; 1974 | 1975 | chk( 3 ) ; 1976 | 1977 | n = *(tos-2) ; 1978 | *(tos-2) = *(tos-1) ; 1979 | *(tos-1) = *(tos) ; 1980 | *tos = n ; 1981 | } 1982 | 1983 | void nip() // n1 n2 -- n2 1984 | { 1985 | 1986 | chk( 2 ) ; 1987 | 1988 | swap() ; 1989 | drop() ; 1990 | } 1991 | 1992 | void tuck() // n1 n2 -- n2 n1 n2 1993 | { 1994 | 1995 | chk( 2 ) ; 1996 | 1997 | dupe() ; 1998 | rot() ; 1999 | swap() ; 2000 | } 2001 | 2002 | void drop() 2003 | { 2004 | chk( 1 ) ; 2005 | 2006 | tos-- ; 2007 | } 2008 | 2009 | void over() // n1 n2 -- n1 n2 n1 2010 | { 2011 | register Cell_t n ; 2012 | 2013 | chk( 2 ) ; 2014 | n = nos ; 2015 | push( n ) ; 2016 | } 2017 | 2018 | void Rto() 2019 | { 2020 | push( rpop() ) ; 2021 | } 2022 | 2023 | void toR() 2024 | { 2025 | 2026 | chk( 1 ) ; 2027 | rpush( pop() ) ; 2028 | } 2029 | 2030 | void swap() 2031 | { 2032 | register Cell_t t ; 2033 | 2034 | chk( 2 ) ; 2035 | t = *tos ; 2036 | *tos = nos ; 2037 | nos = t ; 2038 | } 2039 | 2040 | void pick() 2041 | { 2042 | Wrd_t ix ; 2043 | Cell_t tval ; 2044 | chk( 1 ) ; 2045 | ix = pop() ; 2046 | depth(); tval = pop() ; 2047 | if( ix < tval ){ 2048 | tval = *(tos-ix) ; 2049 | push( tval ) ; 2050 | return ; 2051 | } 2052 | throw( err_StackUdr ) ; 2053 | } 2054 | 2055 | void Eof() 2056 | { 2057 | #ifdef HOSTED 2058 | if( in_This > 0 ) 2059 | { 2060 | close( INPUT ) ; 2061 | INPUT = -1 ; 2062 | in_This-- ; 2063 | if( !isNul( in_Word ) && do_x_Once ) 2064 | { 2065 | do_x_Once = 0 ; 2066 | push( (Cell_t) lookup( in_Word ) ) ; 2067 | execute() ; 2068 | } 2069 | return ; 2070 | } 2071 | throw( err_NoInput ) ; 2072 | catch() ; 2073 | exit( 0 ) ; 2074 | #else 2075 | return ; 2076 | #endif 2077 | } 2078 | 2079 | void cells() 2080 | { 2081 | chk( 1 ) ; 2082 | *tos *= sizeof( Cell_t ) ; 2083 | } 2084 | 2085 | void cellsize() 2086 | { 2087 | push( sizeof( Cell_t ) ) ; 2088 | } 2089 | 2090 | void err_throw( Str_t whence, Wrd_t line, Err_t err ) 2091 | { 2092 | Str_t buf = tb_get( TB ) ; 2093 | 2094 | str_format( buf, tb_bufsize( TB ), "%s():[%d]", whence, line ) ; 2095 | error_loc = buf ; 2096 | error_code = err ; 2097 | } 2098 | 2099 | void catch() 2100 | { 2101 | Wrd_t UNUSED( sz ); 2102 | Input_t *input = &InputStack[ in_This ]; 2103 | 2104 | switch( error_code ){ 2105 | case err_OK: 2106 | return ; 2107 | 2108 | #ifdef HOSTED 2109 | case err_CaughtSignal: 2110 | chk( 0 ) ; 2111 | sz = fmt_out( "%s (%d)\n", errors[error_code], error_code ) ; 2112 | if( sigval == SIGSEGV ){ 2113 | sz = fmt_out( "-- SIGSEGV (%d) is generally non recoverable.\n", sigval ) ; 2114 | goto reset; 2115 | } 2116 | 2117 | Fptr_t ok = signal( sigval, sig_hdlr ) ; 2118 | sz = fmt_out( "-- Signal %d handled. (%x)\n", sigval, ok ) ; 2119 | if( sigval == SIGINT ) 2120 | { 2121 | sz = fmt_out( "-- warm start suggested.\n" ) ; 2122 | Leave(); 2123 | } 2124 | return ; 2125 | goto reset; 2126 | 2127 | case err_SysCall: 2128 | sz = fmt_out( "%s (%d)\n", errors[error_code], error_code ) ; 2129 | sz = fmt_out( "-- %d %s.\n", errno, (Str_t) strerror( errno ) ) ; 2130 | sz = fmt_out( "-- Thrown by %s.\n", error_loc ) ; 2131 | goto reset; 2132 | 2133 | #endif 2134 | 2135 | case err_NoInput: 2136 | default: 2137 | chk( 0 ) ; 2138 | if ( quiet ) return ; 2139 | sz = fmt_out( "%s (%d)\n", errors[error_code], error_code ) ; 2140 | sz = fmt_out( "-- Error: code is %d.\n", error_code ) ; 2141 | sz = fmt_out( "-- Thrown by %s.\n", error_loc ) ; 2142 | if( error_code <= err_Undefined ){ 2143 | sz = fmt_out( "%s (%d).\n", errors[error_code], error_code ) ; 2144 | } 2145 | if( error_code == err_NoInput ){ 2146 | goto die ; 2147 | } 2148 | goto reset; 2149 | } 2150 | 2151 | dump() ; 2152 | sz = fmt_out( "-- Stack Dump: Depth = " ) ; 2153 | dotS() ; cr() ; 2154 | goto reset; 2155 | 2156 | die: 2157 | dump() ; 2158 | sz = fmt_out( "-- Stack Dump: Depth = " ) ; 2159 | dotS() ; cr() ; 2160 | if( error_code != err_OK && error_code != err_NoInput ) 2161 | { 2162 | sz = fmt_out( "-- Abnormal Termination.\n" ) ; 2163 | } 2164 | #ifdef HOSTED 2165 | exit( error_code ) ; 2166 | #endif 2167 | 2168 | reset: 2169 | dump() ; 2170 | fmt_out( "-- Last input: %s\n", input->bytes) ; 2171 | q_reset() ; 2172 | sz = fmt_out( "-- Remaining input flushed.\n" ) ; 2173 | flushtoeol(); 2174 | sz = fmt_out( "-- Attempting Reset.\n" ) ; 2175 | #ifdef HOSTED 2176 | longjmp( env, rst_catch ); 2177 | #endif 2178 | 2179 | } 2180 | 2181 | void wrd_fetch() 2182 | { 2183 | register Cell_t *p ; 2184 | 2185 | chk( 1 ) ; 2186 | p = (Cell_t *) pop() ; 2187 | if( isNul( p ) ){ 2188 | throw( err_NullPtr ) ; 2189 | return ; 2190 | } 2191 | push( *p ) ; 2192 | } 2193 | 2194 | void wrd_store() 2195 | { 2196 | register Cell_t *p, n ; 2197 | 2198 | chk( 2 ) ; 2199 | p = (Cell_t *) pop() ; 2200 | n = pop() ; 2201 | if( isNul( p ) ){ 2202 | throw( err_NullPtr ) ; 2203 | return ; 2204 | } 2205 | *p = n ; 2206 | } 2207 | 2208 | void reg_fetch() 2209 | { 2210 | volatile register uWrd_t *p ; 2211 | 2212 | chk( 2 ) ; 2213 | p = (uWrd_t *) pop() ; 2214 | if( isNul( p ) ){ 2215 | throw( err_NullPtr ) ; 2216 | return ; 2217 | } 2218 | push( *p ) ; 2219 | } 2220 | 2221 | void reg_store() 2222 | { 2223 | volatile register uWrd_t *p ; 2224 | register Cell_t n ; 2225 | 2226 | chk( 2 ) ; 2227 | p = (uWrd_t *) pop() ; 2228 | n = pop() ; 2229 | if( isNul( p ) ){ 2230 | throw( err_NullPtr ) ; 2231 | return ; 2232 | } 2233 | *p = n ; 2234 | } 2235 | 2236 | void crg_fetch() 2237 | { 2238 | volatile register Byt_t *p ; 2239 | 2240 | chk( 1 ) ; 2241 | p = (Byt_t *) pop() ; 2242 | if( isNul( p ) ){ 2243 | throw( err_NullPtr ) ; 2244 | return ; 2245 | } 2246 | push( *p & 0xff ) ; 2247 | } 2248 | 2249 | void crg_store() 2250 | { 2251 | volatile register Byt_t *p ; 2252 | register Cell_t n ; 2253 | 2254 | chk( 2 ) ; 2255 | p = (Byt_t *) pop() ; 2256 | n = pop() ; 2257 | if( isNul( p ) ){ 2258 | throw( err_NullPtr ) ; 2259 | return ; 2260 | } 2261 | *p = n & 0xff ; 2262 | } 2263 | 2264 | void hlf_fetch() 2265 | { 2266 | register Hlf_t *p ; 2267 | 2268 | chk( 1 ) ; 2269 | p = (Hlf_t *) pop() ; 2270 | if( isNul( p ) ){ 2271 | throw( err_NullPtr ) ; 2272 | return ; 2273 | } 2274 | push( *p & _HALFMASK ) ; 2275 | } 2276 | 2277 | void hlf_store() 2278 | { 2279 | volatile register Hlf_t *p ; 2280 | register Cell_t n ; 2281 | 2282 | chk( 2 ) ; 2283 | p = (Hlf_t *) pop() ; 2284 | n = pop() ; 2285 | if( isNul( p ) ){ 2286 | throw( err_NullPtr ) ; 2287 | return ; 2288 | } 2289 | *p = n & _HALFMASK ; 2290 | } 2291 | 2292 | void byt_fetch() 2293 | { 2294 | register Byt_t *p ; 2295 | 2296 | chk( 1 ) ; 2297 | p = (Byt_t *) pop(); 2298 | if( isNul( p ) ){ 2299 | throw( err_NullPtr ) ; 2300 | return ; 2301 | } 2302 | push( *p & 0xff) ; 2303 | } 2304 | 2305 | void byt_store() 2306 | { 2307 | Byt_t *p ; 2308 | Cell_t n ; 2309 | 2310 | chk( 2 ) ; 2311 | p = (Byt_t *) pop() ; 2312 | n = pop() ; 2313 | if( isNul( p ) ){ 2314 | throw( err_NullPtr ) ; 2315 | return ; 2316 | } 2317 | *p = (Byt_t) (n & 0xff) ; 2318 | } 2319 | 2320 | void lft_shift() 2321 | { 2322 | register Cell_t n ; 2323 | 2324 | chk( 2 ) ; 2325 | n = pop() ; 2326 | *tos <<= n ; 2327 | } 2328 | 2329 | void rgt_shift() 2330 | { 2331 | register Cell_t n ; 2332 | 2333 | chk( 2 ) ; 2334 | n = pop() ; 2335 | *tos >>= n ; 2336 | } 2337 | 2338 | void quote() 2339 | { 2340 | push( (Cell_t) str_delimited( "\"" ) ) ; 2341 | if( state == state_Compiling ){ 2342 | ssave() ; 2343 | push( (Cell_t) lookup( "(literal)" ) ) ; 2344 | comma() ; 2345 | comma() ; 2346 | } 2347 | 2348 | } 2349 | 2350 | void dotquote() 2351 | { 2352 | quote() ; 2353 | if( state == state_Compiling ){ 2354 | push( (Cell_t) lookup( "type" ) ) ; 2355 | comma() ; 2356 | return ; 2357 | } 2358 | type() ; 2359 | } 2360 | 2361 | void comment() 2362 | { 2363 | push( (Cell_t) str_delimited( ")" ) ) ; 2364 | drop(); 2365 | } 2366 | 2367 | void flushtoeol() 2368 | { 2369 | Str_t UNUSED( tkn ) ; 2370 | 2371 | // toss tokens until the end of line is reached ... 2372 | do { tkn = str_token( &InputStack[ in_This ] ) ; } while ( ! found_eol ) ; 2373 | 2374 | } 2375 | 2376 | void dotcomment() 2377 | { 2378 | push( (Cell_t) str_delimited( ")" ) ) ; 2379 | type() ; 2380 | } 2381 | 2382 | Str_t str_delimited( Str_t terminator ) 2383 | { 2384 | Str_t tkn, ptr, ret ; 2385 | Wrd_t len ; 2386 | 2387 | ++promptVal ; 2388 | pad() ; ptr = ret = (Str_t) pop() ; 2389 | do { 2390 | word() ; 2391 | tkn = (Str_t) pop() ; 2392 | len = str_length( tkn ) ; 2393 | if( tkn[len-1] == *terminator ){ 2394 | str_copy( ptr, tkn, len-1 ) ; 2395 | ptr[len-1] = (Byt_t) 0 ; 2396 | break ; 2397 | } 2398 | str_copy( ptr, tkn, len ); 2399 | ptr += len ; 2400 | *ptr++ = ' ' ; 2401 | } while( 1 ) ; 2402 | --promptVal ; 2403 | return( ret ) ; 2404 | } 2405 | 2406 | void count() 2407 | { 2408 | Wrd_t len ; 2409 | 2410 | chk( 1 ) ; 2411 | len = str_length( (Str_t) *tos ) ; 2412 | push( (Cell_t) len ) ; 2413 | } 2414 | 2415 | void ssave() 2416 | { 2417 | Str_t str ; 2418 | 2419 | chk( 1 ) ; 2420 | str = (Str_t) pop() ; 2421 | push( (Cell_t) str_cache( str ) ) ; 2422 | } 2423 | 2424 | void unssave() 2425 | { 2426 | Byt_t *tag ; 2427 | 2428 | chk( 1 ) ; 2429 | tag = (Byt_t *) pop(); 2430 | if( isMatch( tag, String_Data+2 ) ){ 2431 | str_uncache( (Str_t) tag ) ; 2432 | return ; 2433 | } 2434 | throw( err_Unsave ) ; 2435 | } 2436 | 2437 | void nBufs() 2438 | { 2439 | push( tb_nbufs( TB ) ) ; 2440 | } 2441 | 2442 | void Buf() 2443 | { 2444 | push( (Cell_t) tb_get( TB ) ) ; 2445 | push( (Cell_t) tb_bufsize( TB ) ) ; 2446 | } 2447 | 2448 | void pad() 2449 | { 2450 | here() ; 2451 | push( 20 ) ; 2452 | cells() ; 2453 | add() ; 2454 | } 2455 | 2456 | void cmove() // ( n dst src -- ) 2457 | { 2458 | Cell_t len ; 2459 | Str_t src, dst ; 2460 | 2461 | len = pop() ; 2462 | dst = (Str_t) pop() ; 2463 | src = (Str_t) pop() ; 2464 | str_copy( dst, src, len ) ; 2465 | } 2466 | 2467 | void word() 2468 | { 2469 | Str_t tkn ; 2470 | 2471 | do { tkn = str_token( &InputStack[ in_This ] ) ; } while ( isNul( tkn ) ) ; 2472 | push( (Cell_t) tkn ) ; 2473 | } 2474 | 2475 | void ascii() 2476 | { 2477 | Str_t p ; 2478 | 2479 | word() ; 2480 | p = (Str_t) pop() ; 2481 | push( (Cell_t) *p ) ; 2482 | if( state == state_Compiling ) 2483 | { 2484 | push( (Cell_t) lookup( "(literal)" ) ) ; 2485 | comma() ; 2486 | comma(); 2487 | } 2488 | } 2489 | 2490 | void q_key() 2491 | { 2492 | #ifdef HOSTED 2493 | #if !defined( __WIN32__ ) 2494 | Wrd_t rv ; 2495 | 2496 | push( (Cell_t) INPUT ) ; 2497 | push( (Cell_t) 0 ) ; 2498 | push( (Cell_t) 0 ) ; 2499 | io_cbreak( INPUT ) ; 2500 | waitrdy() ; 2501 | io_cbreak( INPUT ) ; 2502 | #endif 2503 | #endif 2504 | #ifdef NATIVE 2505 | push( uart_can_recv() ); 2506 | #endif 2507 | } 2508 | 2509 | void key() 2510 | { 2511 | #ifdef HOSTED 2512 | #if !defined( __WIN32__ ) 2513 | 2514 | Byt_t ch ; 2515 | Wrd_t nx, x ; 2516 | 2517 | while( ! io_cbreak( INPUT ) ) ; // turn on cbreak ... 2518 | nx = inp( INPUT, (Str_t) &ch, 1 ) ; 2519 | while( io_cbreak( INPUT ) ) ; // turn off cbreak ... 2520 | if( nx < 1 ) 2521 | { 2522 | push( 0 ) ; 2523 | } else { 2524 | push( ch & 0xff ) ; 2525 | } 2526 | 2527 | #else 2528 | 2529 | push( (Cell_t) (getch() & 0xff) ) ; 2530 | 2531 | #endif 2532 | #endif 2533 | #ifdef NATIVE 2534 | 2535 | push( (Cell_t) uart_getc_ne() & 0xff ); 2536 | 2537 | #endif 2538 | } 2539 | 2540 | void emit() 2541 | { 2542 | Wrd_t nbytes ; 2543 | Byt_t buf[10] ; 2544 | chk( 1 ) ; 2545 | 2546 | nbytes = utf8_encoder( pop(), (Str_t) buf, (Wrd_t) 10 ) ; 2547 | outp( OUTPUT, (Str_t) buf, nbytes ) ; 2548 | } 2549 | 2550 | void type() 2551 | { 2552 | Str_t str ; 2553 | 2554 | chk( 1 ) ; 2555 | str = (Str_t) pop() ; 2556 | outp( OUTPUT, (Str_t) str, str_length( str ) ) ; 2557 | } 2558 | 2559 | void cr() 2560 | { 2561 | outp( OUTPUT, (Str_t) "\n", 1 ) ; 2562 | } 2563 | 2564 | void dp() 2565 | { 2566 | push( (Cell_t) DictPtr ) ; 2567 | } 2568 | 2569 | void stringptr() 2570 | { 2571 | push( (Cell_t) String_Data ) ; 2572 | } 2573 | 2574 | void flashsize() 2575 | { 2576 | push( (Cell_t) sz_FLASH * sizeof( Wrd_t ) ) ; 2577 | } 2578 | 2579 | void flashptr() 2580 | { 2581 | push( (Cell_t) flash_mem ) ; 2582 | } 2583 | 2584 | void here() 2585 | { 2586 | push( (Cell_t) Here ) ; 2587 | } 2588 | 2589 | void freespace() 2590 | { 2591 | push( (Cell_t) ((Str_t) String_Data - (Str_t) Here) ) ; 2592 | } 2593 | 2594 | void comma() 2595 | { 2596 | Cell_t space ; 2597 | 2598 | chk( 1 ) ; 2599 | freespace(); 2600 | space = pop() ; 2601 | if( space > sizeof( Cell_t ) ){ 2602 | push( (Cell_t) Here++ ) ; 2603 | wrd_store() ; 2604 | } else { 2605 | throw( err_NoSpace ) ; 2606 | } 2607 | } 2608 | 2609 | void doLiteral() 2610 | { 2611 | Cell_t *p ; 2612 | p = (Cell_t *) rpop() ; 2613 | push( *(p++) ) ; 2614 | rpush( (Cell_t) p ) ; 2615 | } 2616 | 2617 | void pushPfa() 2618 | { 2619 | push( rpop() ) ; 2620 | } 2621 | 2622 | void does() 2623 | { 2624 | Dict_t *dp ; 2625 | Cell_t **p ; 2626 | 2627 | dp = &Colon_Defs[n_ColonDefs-1] ; 2628 | push( (Cell_t) dp ->pfa ) ; 2629 | dp ->pfa = Here ; 2630 | push( (Cell_t) lookup( "(literal)" ) ) ; 2631 | comma() ; /* push the original pfa */ 2632 | comma() ; 2633 | 2634 | switch( state ){ 2635 | case state_Interactive: 2636 | state = state_Compiling ; 2637 | 2638 | case state_Compiling: 2639 | compile() ; 2640 | return ; 2641 | 2642 | case state_Interpret: /* copy the does> behaviour into the new word */ 2643 | dp ->cfa = doColon ; 2644 | while( (p = (Cell_t **) rpop()) ) { 2645 | dp = (Dict_t *) *p ; ; 2646 | if( isNul( dp ) ){ 2647 | rpush( 0 ) ; /* end of current word interpretation */ 2648 | push( 0 ) ; /* end of defined word (compile next) */ 2649 | comma() ; 2650 | break ; 2651 | } 2652 | rpush( (Cell_t) ++p ) ; 2653 | push( (Cell_t) dp ) ; 2654 | comma() ; 2655 | } 2656 | break ; 2657 | 2658 | default: 2659 | throw( err_BadState ) ; 2660 | } 2661 | } 2662 | 2663 | void allot() 2664 | { 2665 | Cell_t n ; 2666 | 2667 | chk( 1 ) ; 2668 | n = pop() ; 2669 | Here += n ; 2670 | } 2671 | 2672 | void create() 2673 | { 2674 | word(); 2675 | lambda() ; 2676 | } 2677 | 2678 | void lambda() 2679 | { 2680 | Str_t tag ; 2681 | Dict_t *dp ; 2682 | 2683 | tag = (Str_t) pop() ; 2684 | dp = &Colon_Defs[n_ColonDefs++] ; 2685 | 2686 | dp ->nfa = str_cache( tag ) ; // cache tag .. 2687 | dp ->cfa = pushPfa ; // default behaviour (like variable) 2688 | dp ->pfa = Here ; // pfa points to current 2689 | 2690 | } 2691 | 2692 | void doConstant() 2693 | { 2694 | push( rpop() ) ; 2695 | wrd_fetch() ; 2696 | } 2697 | 2698 | void constant() 2699 | { 2700 | create() ; 2701 | comma() ; 2702 | 2703 | Dict_t *dp = &Colon_Defs[n_ColonDefs-1] ; 2704 | dp ->cfa = doConstant ; 2705 | } 2706 | 2707 | void variable() 2708 | { 2709 | create(); 2710 | push( 0 ) ; 2711 | comma() ; 2712 | } 2713 | 2714 | void colon() 2715 | { 2716 | state = state_Compiling ; 2717 | create(); 2718 | compile() ; 2719 | } 2720 | 2721 | void compile() 2722 | { 2723 | Dict_t *dp ; 2724 | Str_t tkn ; 2725 | Cell_t *save, value ; 2726 | 2727 | save = Here ; 2728 | dp = &Colon_Defs[n_ColonDefs-1] ; 2729 | dp ->cfa = doColon ; 2730 | 2731 | ++promptVal ; 2732 | while( (tkn = str_token( &InputStack[ in_This ] )) ){ 2733 | if( isMatch( tkn, ";" ) ){ 2734 | semicolon() ; 2735 | break ; 2736 | } 2737 | dp = (Dict_t *) lookup( tkn ) ; 2738 | if( !isNul( dp ) ){ 2739 | push( (Cell_t) dp ) ; 2740 | if( state == state_Immediate || dp ->flg == Immediate ){ 2741 | execute() ; /* execute */ 2742 | } else { 2743 | comma() ; /* compile */ 2744 | } 2745 | } else { 2746 | value = (Cell_t) str_literal( tkn, Base ) ; 2747 | if( error_code != err_OK ){ 2748 | str_uncache( (Str_t) String_Data ) ; 2749 | Here = save ; 2750 | state = state_Interpret ; 2751 | throw( err_BadString ) ; 2752 | put_str( tkn ) ; 2753 | return ; /* like it never happened */ 2754 | } 2755 | push( value ) ; 2756 | if( state != state_Immediate ){ 2757 | push( (Cell_t) lookup( "(literal)" ) ) ; 2758 | comma() ; 2759 | comma() ; 2760 | } 2761 | } 2762 | } 2763 | } 2764 | 2765 | void pvState() 2766 | { 2767 | state = state_save ; 2768 | } 2769 | 2770 | void imState() 2771 | { 2772 | state_save = state ; 2773 | state = state_Immediate ; 2774 | } 2775 | 2776 | void normal() 2777 | { 2778 | Dict_t *dp ; 2779 | 2780 | dp = &Colon_Defs[n_ColonDefs-1] ; 2781 | dp ->flg = Normal ; 2782 | } 2783 | 2784 | void immediate() 2785 | { 2786 | Dict_t *dp ; 2787 | 2788 | dp = &Colon_Defs[n_ColonDefs-1] ; 2789 | dp ->flg = Immediate ; 2790 | } 2791 | 2792 | void call() 2793 | { 2794 | Cptr_t fun ; 2795 | 2796 | chk( 1 ) ; 2797 | fun = (Cptr_t) pop() ; 2798 | push( (*fun)() ) ; 2799 | } 2800 | 2801 | void tracing( Dict_t *dp ) 2802 | { 2803 | 2804 | dotS() ; 2805 | put_str( "\t\t" ) ; 2806 | 2807 | if( isNul( dp ) ) 2808 | put_str( "next" ) ; 2809 | else 2810 | put_str( dp ->nfa ) ; 2811 | 2812 | cr() ; 2813 | } 2814 | 2815 | void execute() 2816 | { 2817 | Dict_t *dp ; 2818 | 2819 | chk( 1 ) ; 2820 | dp = (Dict_t *) pop() ; 2821 | if( !isNul( dp ) ) 2822 | { 2823 | 2824 | if( dp ->pfa ){ 2825 | rpush( (Cell_t) dp->pfa ) ; 2826 | } 2827 | 2828 | if( Trace ) 2829 | tracing( dp ) ; 2830 | 2831 | (*dp ->cfa)() ; 2832 | catch() ; 2833 | 2834 | } 2835 | } 2836 | 2837 | void doColon() 2838 | { 2839 | Dict_t *dp ; 2840 | Cell_t **p ; 2841 | State_t save ; 2842 | 2843 | save = state ; 2844 | state = state_Interpret ; 2845 | 2846 | while( (p = (Cell_t **) rpop()) ) { 2847 | dp = (Dict_t *) *p ; 2848 | if( isNul( dp ) ){ 2849 | break ; 2850 | } 2851 | rpush( (Cell_t) ++p ) ; 2852 | push( (Cell_t) dp ) ; 2853 | ++_ops ; execute(); 2854 | } 2855 | 2856 | state = save ; 2857 | 2858 | } 2859 | 2860 | void semicolon() 2861 | { 2862 | 2863 | if( state != state_Compiling ){ 2864 | throw( err_BadState ); 2865 | return ; 2866 | } 2867 | push( 0 ) ; /* next is NULL */ 2868 | comma() ; 2869 | --promptVal ; 2870 | state = state_Interactive ; 2871 | } 2872 | 2873 | void tick() 2874 | { 2875 | Str_t tkn ; 2876 | 2877 | chk( 0 ) ; 2878 | word() ; 2879 | tkn = (Str_t) pop() ; 2880 | push( (Cell_t) lookup( tkn ) ) ; 2881 | if( *tos == 0 ){ 2882 | put_str( tkn ) ; 2883 | throw( err_NoWord ) ; 2884 | } 2885 | if( state == state_Compiling ) 2886 | { 2887 | push( (Cell_t) lookup( "(literal)" ) ) ; 2888 | comma() ; 2889 | comma(); 2890 | } 2891 | } 2892 | 2893 | void nfa() 2894 | { 2895 | Dict_t *dp ; 2896 | 2897 | chk( 1 ) ; 2898 | dp = (Dict_t *) pop(); 2899 | push( (Cell_t) dp ->nfa ) ; 2900 | } 2901 | 2902 | void cfa() 2903 | { 2904 | Dict_t *dp ; 2905 | 2906 | chk( 1 ) ; 2907 | dp = (Dict_t *) pop(); 2908 | push( (Cell_t) dp ->cfa ) ; 2909 | } 2910 | 2911 | void pfa() 2912 | { 2913 | Dict_t *dp ; 2914 | 2915 | chk( 1 ) ; 2916 | dp = (Dict_t *) pop() ; 2917 | push( (Cell_t) dp ->pfa ) ; 2918 | } 2919 | 2920 | void decimal() 2921 | { 2922 | Base = 10 ; 2923 | } 2924 | 2925 | void hex() 2926 | { 2927 | Base = 16 ; 2928 | } 2929 | 2930 | void sigvar() 2931 | { 2932 | #ifdef HOSTED 2933 | push( (Cell_t) &sigval ); 2934 | #endif 2935 | } 2936 | 2937 | void errvar() 2938 | { 2939 | push( (Cell_t) &error_code ); 2940 | } 2941 | 2942 | void errval() 2943 | { 2944 | errvar(); 2945 | wrd_fetch(); 2946 | } 2947 | 2948 | void errstr() 2949 | { 2950 | 2951 | register Cell_t err = pop() ; 2952 | 2953 | if( err >= err_OK && err <= err_Undefined ) 2954 | push( errors[ err ] ) ; 2955 | else 2956 | throw( err_Range ) ; 2957 | return ; 2958 | } 2959 | 2960 | void errmax() 2961 | { 2962 | push( err_Undefined ) ; 2963 | } 2964 | 2965 | void trace() 2966 | { 2967 | push( (Cell_t) &Trace ); 2968 | } 2969 | 2970 | void base() 2971 | { 2972 | push( (Cell_t) &Base ); 2973 | } 2974 | 2975 | void resetter() 2976 | { 2977 | put_str( "-- Warm start." ) ; cr(); 2978 | q_reset() ; 2979 | #ifdef HOSTED 2980 | longjmp( env, rst_user ) ; 2981 | #endif 2982 | } 2983 | 2984 | void cold() 2985 | { 2986 | put_str( "-- Cold start." ) ; cr(); 2987 | q_reset() ; 2988 | forget() ; 2989 | #ifdef HOSTED 2990 | longjmp( env, rst_coldstart ) ; 2991 | #else 2992 | #endif 2993 | } 2994 | 2995 | void see() 2996 | { 2997 | register Dict_t *p, *r ; 2998 | Cell_t *ptr, n ; 2999 | 3000 | chk( 1 ) ; 3001 | 3002 | p = (Dict_t *) pop() ; 3003 | if( isNul( p ->pfa ) ){ 3004 | n = fmt_out( "-- %s (%x) flg: %d is coded in C (%x).\n", p ->nfa, p, p->flg, p ->cfa ) ; 3005 | return ; 3006 | } else { 3007 | if( p ->cfa == (Fptr_t) doConstant ){ 3008 | n = fmt_out( "-- %s constant value (0x%x).\n", p ->nfa, *p->pfa ) ; 3009 | return ; 3010 | } 3011 | if( p ->cfa == (Fptr_t) pushPfa ){ 3012 | n = fmt_out( "-- %s variable value (0x%x).\n", p ->nfa, *p->pfa ) ; 3013 | return ; 3014 | } 3015 | n = fmt_out( "-- %s (%x) word flg: %d.\n", p ->nfa, p, p->flg ) ; 3016 | } 3017 | ptr = p ->pfa ; 3018 | while( !isNul( ptr ) ){ 3019 | r = (Dict_t *) *ptr ; 3020 | if( isNul( r ) ){ /* next == NULL */ 3021 | n = fmt_out( "%x next\n", ptr ) ; 3022 | break ; 3023 | } 3024 | Str_t buf = tb_get( TB ) ; 3025 | if( r ->cfa == (Fptr_t) branch ){ 3026 | n = str_format( buf, tb_bufsize( TB ), "%x %s -> %x\n", ptr, r ->nfa, *(ptr+1) ) ; 3027 | ptr++ ; 3028 | } else if( r ->cfa == (Fptr_t) q_branch ){ 3029 | n = str_format( buf, tb_bufsize( TB ), "%x %s -> %x\n", ptr, r ->nfa, *(ptr+1) ) ; 3030 | ptr++ ; 3031 | } else if( r ->cfa == (Fptr_t) doLiteral ){ 3032 | n = str_format( buf, tb_bufsize( TB ), "%x %s = %d\n", ptr, r ->nfa, *(ptr+1) ) ; 3033 | ptr++ ; 3034 | } else { 3035 | n = str_format( buf, tb_bufsize( TB ), "%x %s\n", ptr, r ->nfa ) ; 3036 | } 3037 | outp( OUTPUT, (Str_t) buf, n ) ; 3038 | ptr++ ; 3039 | } 3040 | } 3041 | 3042 | /* 3043 | -- I/O routines -- 3044 | 3045 | must be written for the Atmel AVR's, but 3046 | any HOSTED (Linux/Unix/Windows) system can simply use read/write. 3047 | key and ?key are special cases (len == 1), 3048 | and cbreak has been added for processing for tty's. 3049 | 3050 | For Native ARM based systems, we will be implementing uart put/get functions 3051 | and a get without echo (for key) ... 3052 | 3053 | */ 3054 | 3055 | Wrd_t fmt_out( Str_t fmt, ... ) 3056 | { 3057 | va_list ap ; 3058 | Wrd_t nx, siz ; 3059 | Str_t buf = tb_get( TB ); 3060 | 3061 | siz = tb_bufsize( TB ) ; 3062 | va_start( ap, fmt ); 3063 | nx = str_format_ap( buf, siz, fmt, ap ) ; 3064 | va_end( ap ) ; 3065 | 3066 | outp( OUTPUT, buf, nx ); 3067 | return nx ; 3068 | } 3069 | 3070 | Wrd_t put_str( Str_t s ) 3071 | { 3072 | register Cell_t n = 0; 3073 | 3074 | if( !isNul( s ) ){ 3075 | n = str_length( s ) ; 3076 | outp( OUTPUT, s, n ) ; 3077 | outp( OUTPUT, " ", 1 ) ; 3078 | } 3079 | return n ; 3080 | } 3081 | 3082 | Wrd_t get_str( Wrd_t fd, Str_t buf, Wrd_t len ) 3083 | { 3084 | Byt_t ch ; 3085 | Wrd_t i, crlf = 0 ; 3086 | 3087 | str_set( buf, 0, len ) ; 3088 | 3089 | i = 0 ; 3090 | do { 3091 | if( i > (len - 1) ){ 3092 | return i ; 3093 | } 3094 | 3095 | key() ; ch = pop() & 0xff ; 3096 | if( ch == 0 ) 3097 | { 3098 | return i ; 3099 | } 3100 | 3101 | if( ch_matches( ch, "\r\n" ) ){ 3102 | crlf++ ; 3103 | } 3104 | 3105 | buf[i++] = (Byt_t) ch ; 3106 | 3107 | } while( crlf < 1 ) ; 3108 | return i ; 3109 | } 3110 | 3111 | Wrd_t io_cbreak( int fd ) 3112 | { 3113 | #if defined( HOSTED ) 3114 | #if !defined(__WIN32__) 3115 | static int inCbreak = v_Off ; 3116 | static struct termios tty_state, *tty_orig = (struct termios *) NULL ; 3117 | int rv ; 3118 | 3119 | if( isNul( tty_orig ) ){ 3120 | rv = tcgetattr( fd, &tty_normal_state ); 3121 | tty_orig = &tty_normal_state ; 3122 | } 3123 | 3124 | switch( inCbreak ){ 3125 | case v_Off: 3126 | rv = tcgetattr( fd, &tty_state ) ; 3127 | cfmakeraw( &tty_state ) ; 3128 | rv = tcsetattr( fd, TCSANOW, &tty_state ) ; 3129 | inCbreak = v_On ; 3130 | break ; 3131 | case v_On: 3132 | rv = tcsetattr( fd, TCSANOW, tty_orig ) ; 3133 | inCbreak = v_Off ; 3134 | } 3135 | return inCbreak ; 3136 | #endif 3137 | #else 3138 | return v_On ; 3139 | #endif 3140 | } 3141 | 3142 | void waitrdy() // fd secs usecs -- flag ) 3143 | { 3144 | #ifdef HOSTED 3145 | #if !defined( __WIN32__ ) 3146 | Wrd_t rv, fd, secs, usecs ; 3147 | fd_set fds ; 3148 | struct timeval tmo ; 3149 | 3150 | usecs = pop() ; 3151 | secs = pop() ; 3152 | fd = pop() ; 3153 | 3154 | FD_ZERO( &fds ) ; 3155 | FD_SET( fd, &fds ) ; 3156 | 3157 | tmo.tv_sec = secs ; 3158 | tmo.tv_usec = usecs ; 3159 | rv = select( fd+1, &fds, NULL, NULL, &tmo ) ; 3160 | if( rv < 0 ){ 3161 | throw( err_SysCall ) ; 3162 | } 3163 | push( FD_ISSET( fd, &fds ) ) ; 3164 | #endif 3165 | #endif 3166 | } 3167 | 3168 | void sndtty() // ( fd ptr -- nx ) 3169 | { 3170 | Str_t str ; 3171 | Wrd_t fd, len ; 3172 | 3173 | chk( 2 ) ; 3174 | 3175 | len = str_length( (Str_t) *tos ) ; 3176 | str = (Str_t) pop() ; 3177 | fd = pop() ; 3178 | push( (Cell_t) outp( fd, str, len ) ) ; 3179 | } 3180 | 3181 | #ifdef HOSTED 3182 | void rcvtty() // ( fd n -- buf n ) 3183 | { 3184 | Str_t buf ; 3185 | Wrd_t n, nr, fd ; 3186 | 3187 | chk( 2 ) ; 3188 | 3189 | n = pop() ; 3190 | fd = pop() ; 3191 | here() ; buf = (Str_t) pop() + 8 * sizeof( Cell_t ) ; 3192 | in_files[++in_This] = fd ; 3193 | nr = get_str( fd, buf, n ) ; 3194 | --in_This ; 3195 | push( (Cell_t) buf ) ; 3196 | push( (Cell_t) nr ) ; 3197 | return ; 3198 | } 3199 | #endif 3200 | 3201 | void opentty() // ( str -- fd ) 3202 | { 3203 | #ifdef HOSTED 3204 | #if !defined(__WIN32__) 3205 | Str_t fn ; 3206 | Wrd_t rv, fd ; 3207 | struct termios tty_state ; 3208 | 3209 | chk( 1 ) ; 3210 | 3211 | fn = (Str_t) pop() ; 3212 | if( !isNul( fn ) ){ 3213 | fd = open( fn, O_RDWR | O_NDELAY | O_NONBLOCK | O_NOCTTY ) ; 3214 | if( fd < 0 ){ 3215 | throw( err_SysCall ) ; 3216 | return ; 3217 | } 3218 | rv = tcgetattr( fd, &tty_state ) ; 3219 | cfsetspeed( &tty_state, B115200 ) ; 3220 | tty_state.c_lflag &= ~(ICANON | ECHO | ECHOE | ISIG ) ; 3221 | cfmakeraw( &tty_state ) ; 3222 | rv = tcsetattr( fd, TCSANOW, &tty_state ) ; 3223 | if( rv < 0 ){ 3224 | throw( err_SysCall ) ; 3225 | return ; 3226 | } 3227 | } 3228 | push( fd ) ; 3229 | #endif 3230 | #endif 3231 | } 3232 | 3233 | void closetty() // ( fd -- ) 3234 | { 3235 | #ifdef HOSTED 3236 | chk( 1 ) ; 3237 | close( (Wrd_t) pop() ) ; 3238 | #endif 3239 | } 3240 | 3241 | void infile() 3242 | { 3243 | chk( 1 ) ; 3244 | 3245 | Str_t fn = (Str_t) pop() ; 3246 | 3247 | if( isMatch( fn, "stdin" ) ) // intialize ... 3248 | { 3249 | in_This = 0 ; 3250 | InputStack[ in_This ].file = 0 ; 3251 | InputStack[ in_This ].bytes_read = -1 ; 3252 | InputStack[ in_This ].bytes_this = -1 ; 3253 | InputStack[ in_This ].in_line = 0 ; 3254 | InputStack[ in_This ].name = str_cache( fn ) ; 3255 | InputStack[ in_This ].bytes = (Str_t) inbuf[ in_This ] ; 3256 | return ; 3257 | } 3258 | 3259 | #ifdef HOSTED 3260 | 3261 | if( in_This < sz_FILES ) // push a new input file ... 3262 | { 3263 | if( !isNul( fn ) ) 3264 | { 3265 | in_This += 1 ; 3266 | InputStack[ in_This ].bytes_read = -1 ; 3267 | InputStack[ in_This ].bytes_this = -1 ; 3268 | InputStack[ in_This ].in_line = 0 ; 3269 | InputStack[ in_This ].name = str_cache( fn ) ; 3270 | InputStack[ in_This ].bytes = (Str_t) inbuf[ in_This ] ; 3271 | InputStack[ in_This ].file = open( InputStack[ in_This ].name , O_RDONLY ) ; 3272 | 3273 | if( InputStack[ in_This ].file < 0 ) 3274 | { 3275 | str_uncache( fn ) ; 3276 | if( !isNul( off_path ) ) // add the file path and try again ... 3277 | { 3278 | Str_t buf = tb_get( TB ) ; 3279 | str_format( buf, tb_bufsize( TB ), "%s/%s", (Str_t) off_path, (Str_t) fn ) ; 3280 | InputStack[ in_This ].name = str_cache( (Str_t) buf ) ; 3281 | InputStack[ in_This ].file = open( InputStack[ in_This ].name , O_RDONLY ) ; 3282 | } 3283 | } 3284 | 3285 | if( InputStack[ in_This ].file < 0 ) 3286 | { 3287 | in_This-- ; 3288 | throw( err_NoFile ) ; 3289 | } 3290 | } 3291 | 3292 | return ; 3293 | 3294 | } 3295 | 3296 | throw( err_InStack ) ; 3297 | return ; 3298 | 3299 | #endif 3300 | } 3301 | 3302 | void filename() 3303 | { 3304 | push( (Str_t) InputStack[ in_This ].name ) ; 3305 | } 3306 | 3307 | void outfile() 3308 | { 3309 | #ifdef HOSTED 3310 | Str_t fn ; 3311 | Cell_t fd, fexists ; 3312 | uCell_t fflg = O_CREAT | O_RDWR | O_APPEND ; 3313 | 3314 | fn = (Str_t) pop() ; 3315 | if( !isNul( fn ) ){ 3316 | #if !defined( __WIN32__ ) 3317 | uCell_t fprm = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH ; 3318 | fd = open( fn, fflg, fprm ) ; 3319 | #else 3320 | fd = open( fn, fflg ) ; 3321 | #endif 3322 | if( fd < 0 ){ 3323 | throw( err_NoFile ) ; 3324 | return ; 3325 | } 3326 | out_files[++out_This] = fd ; 3327 | return ; 3328 | } 3329 | #endif 3330 | } 3331 | 3332 | void closeout() 3333 | { 3334 | #ifdef HOSTED 3335 | if( out_This > 0 ){ 3336 | close( OUTPUT ) ; 3337 | out_This-- ; 3338 | } 3339 | #endif 3340 | } 3341 | 3342 | void isfile() 3343 | { 3344 | #ifdef HOSTED 3345 | struct stat sbuf ; 3346 | Cell_t rv ; 3347 | Str_t fn = (Str_t) pop() ; 3348 | 3349 | if( !isNul( fn ) ) 3350 | { 3351 | rv = stat( (const Str_t ) fn, &sbuf ) ; 3352 | if( rv < 0 ) 3353 | { 3354 | throw( err_SysCall ) ; 3355 | } 3356 | } 3357 | push( (rv == 0) ? 1 : 0 ) ; 3358 | #endif 3359 | } 3360 | 3361 | Wrd_t outp( Wrd_t fd, Str_t buf, Wrd_t len ) 3362 | { 3363 | #ifdef HOSTED 3364 | Wrd_t nx ; 3365 | 3366 | again: 3367 | nx = write( fd, buf, len ) ; 3368 | if( nx < 0 ) 3369 | { 3370 | if( errno == EINTR ) 3371 | goto again ; 3372 | } 3373 | return nx ; 3374 | 3375 | #endif 3376 | #ifdef NATIVE 3377 | Wrd_t i ; 3378 | 3379 | for( i = 0 ; i < len; i++ ) 3380 | { 3381 | uart_putc( (unsigned) buf[i]&0xff ); 3382 | } 3383 | return i ; 3384 | 3385 | #endif 3386 | } 3387 | 3388 | Wrd_t inp( Wrd_t fd, Str_t buf, Wrd_t len ) 3389 | { 3390 | 3391 | #ifdef HOSTED 3392 | Wrd_t nx ; 3393 | 3394 | again: 3395 | nx = read( fd, buf, len ) ; 3396 | if( nx < 0 ) 3397 | { 3398 | if( errno == EINTR ) 3399 | goto again ; 3400 | } 3401 | return nx ; 3402 | #endif 3403 | 3404 | #ifdef NATIVE 3405 | Cell_t c, x, i = 0 ; 3406 | 3407 | str_set( buf, 0, len ) ; 3408 | while( i < len ) 3409 | { 3410 | buf[i++] = c = uart_getc(); 3411 | if( c == 0x15 ) // NAK 3412 | { 3413 | str_set( buf, 0, len ) ; 3414 | int slen = str_length( buf ) ; 3415 | uart_putc( 0x0a ) ; 3416 | for( x = 0 ; x < slen; x++ ) 3417 | uart_putc( 0x20 ) ; 3418 | uart_putc( 0x0a ) ; 3419 | i = 0 ; 3420 | continue ; 3421 | } 3422 | if( c == 0x08 || c == 0x7f ) // backspace || delete 3423 | { 3424 | buf[--i] = 0x00 ; // backspace 3425 | buf[--i] = 0x00 ; // bad char 3426 | i = i < 0 ? 0 : i ; 3427 | uart_putc( 0x20 ) ; // space 3428 | uart_putc( 0x08 ) ; // backspace 3429 | continue ; 3430 | } 3431 | if( c == 0x0d ) // return 3432 | { 3433 | uart_putc( 0x0a ) ; // newline 3434 | break ; 3435 | } 3436 | } 3437 | return i ; 3438 | #endif 3439 | } 3440 | 3441 | #if defined avr || defined AVR 3442 | Wrd_t read( Wrd_t fd, Str_t buf, Wrd_t len ) {} 3443 | Wrd_t write( Wrd_t fd, Str_t buf, Wrd_t len ) {} 3444 | #endif 3445 | 3446 | #ifdef HOSTED 3447 | void qdlopen() 3448 | { 3449 | Str_t lib ; 3450 | Opq_t opaque ; 3451 | 3452 | chk( 1 ) ; 3453 | lib = (Str_t) pop() ; 3454 | opaque = dlopen( lib, RTLD_NOW | RTLD_GLOBAL ) ; 3455 | push( (Cell_t) opaque ) ; 3456 | } 3457 | 3458 | void qdlclose() 3459 | { 3460 | Opq_t opaque ; 3461 | 3462 | chk( 1 ) ; 3463 | opaque = (Opq_t) pop() ; 3464 | push( (Cell_t) dlclose( opaque ) ) ; 3465 | } 3466 | 3467 | void qdlsym() 3468 | { 3469 | Str_t symbol ; 3470 | Opq_t handle ; 3471 | 3472 | chk( 2 ) ; 3473 | symbol = (Str_t) pop() ; 3474 | handle = (Opq_t) pop() ; 3475 | push( (Cell_t) dlsym( handle, symbol ) ) ; 3476 | } 3477 | 3478 | void qdlerror() 3479 | { 3480 | push( (Cell_t) dlerror() ) ; 3481 | } 3482 | 3483 | void last_will() 3484 | { 3485 | Opq_t cmd ; 3486 | 3487 | chk( 1 ) ; 3488 | cmd = (Opq_t) pop() ; 3489 | atexit( cmd ) ; 3490 | } 3491 | 3492 | void spinner() 3493 | { 3494 | static Wrd_t ix = 0 ; 3495 | Byt_t f[4] = { '-', '\\', '|', '/' } ; 3496 | 3497 | push( f[ ix++ % 4 ] ) ; 3498 | emit(); 3499 | push( '\r' ) ; 3500 | emit(); 3501 | 3502 | } 3503 | #endif /* HOSTED */ 3504 | 3505 | void callout() 3506 | { 3507 | Cptr_t fun ; 3508 | Cell_t i, n ; 3509 | Cell_t args[10] ; 3510 | 3511 | fun = (Cptr_t) pop() ; 3512 | n = pop() ; 3513 | 3514 | chk( n ) ; /* really need n+2 items ... */ 3515 | 3516 | for( i = n-1 ; i >= 0 ; i-- ){ 3517 | args[i] = pop() ; 3518 | } 3519 | 3520 | switch( n ){ 3521 | case 0: 3522 | push( (*fun)() ) ; 3523 | break ; 3524 | case 1: 3525 | push( (*fun)( args[0] ) ) ; 3526 | break ; 3527 | case 2: 3528 | push( (*fun)( args[0], args[1] ) ) ; 3529 | break ; 3530 | case 3: 3531 | push( (*fun)( args[0], args[1], args[2] ) ) ; 3532 | break ; 3533 | case 4: 3534 | push( (*fun)( args[0], args[1], args[2], args[3] ) ) ; 3535 | break ; 3536 | case 5: 3537 | push( (*fun)( args[0], args[1], args[2], args[3], args[4] ) ) ; 3538 | break ; 3539 | case 6: 3540 | push( (*fun)( args[0], args[1], args[2], args[3], args[4], args[5] ) ) ; 3541 | break ; 3542 | case 7: 3543 | push( (*fun)( args[0], args[1], args[2], args[3], args[4], args[5], args[6] ) ) ; 3544 | break ; 3545 | case 8: 3546 | push( (*fun)( args[0], args[1], args[2], args[3], args[4], args[5], args[6], args[7] ) ) ; 3547 | break ; 3548 | case 9: 3549 | push( (*fun)( args[0], args[1], args[2], args[3], args[4], args[5], args[6], args[7], args[8] ) ) ; 3550 | break ; 3551 | } 3552 | return ; 3553 | } 3554 | 3555 | void clkspersec() 3556 | { 3557 | #ifdef HOSTED 3558 | push( CLOCKS_PER_SEC ) ; 3559 | #else 3560 | push( -1 ) ; 3561 | #endif 3562 | } 3563 | 3564 | void plusplus() 3565 | { 3566 | *(tos) += 1; 3567 | } 3568 | 3569 | void minusminus() 3570 | { 3571 | *(tos) -= 1; 3572 | } 3573 | 3574 | void utime() 3575 | { 3576 | #ifdef HOSTED 3577 | struct timeval tv ; 3578 | uint64_t rv = 0ULL ; 3579 | 3580 | gettimeofday( &tv, NULL ) ; 3581 | push( ( tv.tv_sec * 1000000 ) + tv.tv_usec ) ; 3582 | #else 3583 | push( -1 ) ; 3584 | #endif 3585 | } 3586 | 3587 | void ops() 3588 | { 3589 | push( _ops ) ; 3590 | } 3591 | 3592 | void noops() 3593 | { 3594 | _ops = 0 ; 3595 | } 3596 | 3597 | void qdo() 3598 | { 3599 | push( (Cell_t) lookup( "(do)" ) ) ; 3600 | comma() ; 3601 | bkw_mark(); 3602 | } 3603 | 3604 | void do_do() 3605 | { 3606 | Cell_t nxt ; 3607 | 3608 | chk( 2 ) ; 3609 | nxt = rpop() ; 3610 | swap() ; 3611 | rpush( pop() ) ; /* end point */ 3612 | rpush( pop() ) ; /* index */ 3613 | rpush( nxt ) ; 3614 | } 3615 | 3616 | void do_loop() 3617 | { 3618 | Cell_t nxt ; 3619 | 3620 | nxt = (Cell_t ) rpop() ; // save nxt 3621 | if ( *(rtos)+1 < *(rnos) ){ // if i < n 3622 | *rtos += 1; // ++i 3623 | rpush( nxt ) ; // restore nxt 3624 | push( 0 ) ; // flag for ?branch 3625 | return ; 3626 | } 3627 | 3628 | rtos-- ; rtos-- ; // drop i, n 3629 | rpush( nxt ) ; // restore nxt 3630 | push( 1 ) ; // flag for ?branch 3631 | 3632 | } 3633 | 3634 | void loop() 3635 | { 3636 | 3637 | push( (Cell_t) lookup( "(loop)" ) ); 3638 | comma(); 3639 | 3640 | push( (Cell_t) lookup( "?branch" ) ); 3641 | comma() ; 3642 | bkw_resolve() ; 3643 | 3644 | } 3645 | 3646 | void do_I() 3647 | { 3648 | push( *rnos ); 3649 | } 3650 | 3651 | void ploop() 3652 | { 3653 | 3654 | push( (Cell_t) lookup( "(+loop)" ) ); 3655 | comma(); 3656 | 3657 | push( (Cell_t) lookup( "?branch" ) ); 3658 | comma() ; 3659 | bkw_resolve() ; 3660 | 3661 | } 3662 | 3663 | void do_ploop() 3664 | { 3665 | Cell_t nxt, inc ; 3666 | 3667 | inc = pop() ; 3668 | nxt = (Cell_t ) rpop() ; 3669 | if ( inc > 0 ) /* positive increment */ 3670 | { 3671 | if ( ( *(rtos) + inc )< *(rnos) ){ 3672 | *rtos += inc ; 3673 | rpush( nxt ) ; 3674 | push( 0 ) ; 3675 | return ; 3676 | } 3677 | 3678 | } else { /* negative increment */ 3679 | if ( ( *(rtos) + inc )> *(rnos) ){ 3680 | *rtos += inc ; 3681 | rpush( nxt ) ; 3682 | push( 0 ) ; 3683 | return ; 3684 | } 3685 | 3686 | } 3687 | 3688 | rtos-- ; rtos-- ; // drop i, n ... 3689 | rpush( nxt ) ; // restore nxt ... 3690 | push( 1 ) ; // flag for ?branch ... 3691 | 3692 | } 3693 | 3694 | void forget() 3695 | { 3696 | if( !isNul( TB ) ) 3697 | { 3698 | TB = tb_destroy( TB ) ; 3699 | } 3700 | TB = tb_create( &T, (Byt_t *) tmp_buffer, (Wrd_t) sz_TMPBUFFER, (Wrd_t) nm_TMPBUFFER ) ; 3701 | 3702 | Here = (Cell_t *) StartOf( flash ) ; // erase colon defs vars and constants ... 3703 | DictPtr = (Cell_t *) StartOf( flash ) ; // set the dictptr to here ... 3704 | n_ColonDefs = 0 ; // uncount the colon defs ... 3705 | Base = 10 ; 3706 | Trace = 0 ; 3707 | state = state_Interactive ; 3708 | 3709 | if( isNul( String_LowWater ) ) 3710 | String_Data = (Byt_t *) (&flash[sz_FLASH - 1]) ; // erase the string data referenced in the dictionary 3711 | else 3712 | String_Data = (Byt_t *) String_LowWater ; 3713 | } 3714 | 3715 | int sign_is_negative = 0 ; 3716 | 3717 | void fmt_start() // ( n -- n ) 3718 | { 3719 | Str_t ptr ; 3720 | 3721 | chk( 1 ) ; 3722 | 3723 | sign_is_negative = 0 ; 3724 | ptr = tb_get( TB ) + tb_bufsize( TB ) - 1 ; 3725 | *(ptr--) = (Byt_t) 0 ; // drop a null byte at the end of the buffer ... 3726 | push( ptr ) ; // back the buffer up for the next char ... 3727 | swap() ; // ( n ptr -- ptr n ) 3728 | } 3729 | 3730 | void fmt_digit() // ( n -- n2 ) : # dup base @ % . base @ / ; 3731 | { 3732 | register Cell_t n, digit ; 3733 | Str_t ptr ; 3734 | 3735 | if( *tos ) 3736 | { 3737 | // fmt_sign() ; 3738 | n = pop() ; // ( ptr n -- ptr ) 3739 | ptr = (Str_t) pop() ; // ( ptr -- ) 3740 | digit = ( (Abs( n ) % Base) ) ; 3741 | n /= Base ; 3742 | *(ptr--) = digits[digit] ; 3743 | push( ptr ) ; // ( ptr -- ptr-1 ) 3744 | push( n ) ; // ( ptr -- ptr n2 ) 3745 | } else { 3746 | push( (Cell_t) '0' ) ; // ( ptr n -- ptr n 0 ) 3747 | fmt_hold() ; // ( ptr n 0 -- ptr-1 n ) 3748 | } 3749 | } 3750 | 3751 | void fmt_hold() // ( x n -- x ) 3752 | { 3753 | Cell_t n ; 3754 | Str_t ptr ; 3755 | 3756 | n = pop() ; // ( ptr x n -- ptr x ) 3757 | ptr = (Str_t) nos ; // ( ptr x -- ptr x ) 3758 | *ptr = (Byt_t) n ; // ( ptr x -- ptr-1 x ) 3759 | nos = (Cell_t) --ptr ; 3760 | } 3761 | 3762 | void fmt_sign() // ( n -- n ) 3763 | { 3764 | if( *tos != 0 && *tos < 0 ) 3765 | { 3766 | sign_is_negative = 1 ; 3767 | } 3768 | } 3769 | 3770 | void fmt_num() // ( n -- 0 ) 3771 | { 3772 | while( *tos ) fmt_digit() ; 3773 | } 3774 | 3775 | void fmt_end() // ( n -- ) 3776 | { 3777 | if( sign_is_negative ) 3778 | { 3779 | push( (Cell_t) '-' ) ; 3780 | fmt_hold() ; 3781 | } 3782 | drop() ; 3783 | plusplus() ; 3784 | } 3785 | 3786 | void utf8_encode() // ( char buf len -- len ) 3787 | { 3788 | Cell_t ch, len ; 3789 | Str_t buf ; 3790 | 3791 | chk( 3 ) ; 3792 | len = (Wrd_t) pop() ; 3793 | buf = (Str_t) pop() ; 3794 | ch = (Wrd_t) pop() ; 3795 | 3796 | push( (Wrd_t) utf8_encoder( ch, buf, len ) ) ; 3797 | } 3798 | 3799 | void accept() // ( buf len -- len ) 3800 | { 3801 | Cell_t len ; 3802 | Str_t buf ; 3803 | 3804 | len = (Wrd_t) pop() ; 3805 | buf = (Str_t) pop() ; 3806 | 3807 | push( (Wrd_t) get_str( INPUT, buf, len ) ) ; 3808 | 3809 | } 3810 | 3811 | void dump() 3812 | { 3813 | Cell_t **p ; 3814 | Dict_t *dp ; 3815 | 3816 | if( quiet ) return ; 3817 | 3818 | fmt_out( "-- Input File: %s Line: %d:\n", InputStack[ in_This ].name, InputStack[ in_This ].in_line ) ; 3819 | fmt_out( "-- Forth Backtrace:\n" ) ; 3820 | while( rtos != StartOf( rstack ) ) 3821 | { 3822 | p = (Cell_t **) rpop() ; 3823 | if( !isNul( p ) ) 3824 | { 3825 | dp = (Dict_t *) *p ; 3826 | if( !isNul( dp ) ) 3827 | fmt_out( " -- %x %x (%s)\n", (p), dp, dp->nfa ) ; 3828 | 3829 | dp = (Dict_t *) *(p-1) ; 3830 | if( !isNul( dp ) ) 3831 | { 3832 | fmt_out( " -- %x %x (%s)\n", (p-1), dp, dp->nfa ) ; 3833 | } 3834 | } 3835 | } 3836 | } 3837 | 3838 | void find() // ( strptr -- dp|0 ) 3839 | { 3840 | Str_t tkn = (Str_t) pop() ; 3841 | push( ((Dict_t *) lookup( (Str_t) tkn )) ) ; 3842 | } 3843 | 3844 | #ifdef HOSTED 3845 | void path() 3846 | { 3847 | push( off_path ) ; 3848 | } 3849 | #endif 3850 | 3851 | void version() 3852 | { 3853 | push( str_literal( MAJOR, Base ) ) ; 3854 | push( str_literal( MINOR, Base ) ) ; 3855 | push( str_literal( REVISION, Base ) ) ; 3856 | 3857 | } 3858 | 3859 | void data() 3860 | { 3861 | push( (Cell_t *) Colon_Defs ); 3862 | } 3863 | 3864 | void code() 3865 | { 3866 | push( (Cell_t *) Primitives ); 3867 | } 3868 | 3869 | void align() // ( adr -- adr' ) 3870 | { 3871 | Cell_t adr = *tos ; 3872 | 3873 | while( adr % sizeof( Cell_t ) ) 3874 | { 3875 | adr++; 3876 | } 3877 | *tos = adr ; 3878 | } 3879 | 3880 | void fill() // ( dst n char -- ) 3881 | { 3882 | Byt_t ch ; 3883 | Wrd_t n ; 3884 | Str_t dst ; 3885 | 3886 | chk( 3 ) ; 3887 | ch = (Byt_t) pop() ; 3888 | n = (Wrd_t) pop() ; 3889 | dst = (Str_t) pop() ; 3890 | str_set( dst, ch, n ) ; 3891 | } 3892 | 3893 | // a late addition to OneFileForth is a circular buffer queue designed to 3894 | // return a reasonably sized buffer chunk from a fixed memory location in 3895 | // a round robin fashion, such that internal memory requirements will not 3896 | // conflict ... this is an internal only implementation ... see Buf(). 3897 | Cir_Queue_t *tb_create( Cir_Queue_t *rv, Byt_t *memory, Wrd_t size, Wrd_t n_elements ) 3898 | { 3899 | Wrd_t chunksz = 0 ; 3900 | 3901 | if( size > CQ_MAX_BUFFER ) 3902 | { 3903 | return (Cir_Queue_t *) rv ; 3904 | } 3905 | 3906 | if( n_elements < CQ_MIN_CHUNKS ) 3907 | { 3908 | return (Cir_Queue_t *) rv ; 3909 | } 3910 | 3911 | chunksz = (size / n_elements ) ; 3912 | 3913 | str_set( (Str_t) memory, 0, size ) ; 3914 | rv -> cq_memory = (Str_t) memory ; 3915 | rv -> cq_memsize = size ; 3916 | rv -> cq_chunksize = (uint16_t) chunksz ; 3917 | rv -> cq_n_elements = n_elements ; 3918 | rv -> cq_next = 0 ; 3919 | rv -> cq_buffer = (Str_t) memory ; 3920 | return rv ; 3921 | } 3922 | 3923 | Cir_Queue_t *tb_destroy( Cir_Queue_t *CQ ) 3924 | { 3925 | if( !isNul( CQ ) ) 3926 | { 3927 | CQ ->cq_next = 0 ; 3928 | str_set( (Str_t) CQ ->cq_memory, 0, CQ ->cq_memsize ) ; 3929 | } 3930 | return (Cir_Queue_t *) NULL ; 3931 | } 3932 | 3933 | int tb_nbufs( Cir_Queue_t *CQ ) 3934 | { 3935 | return CQ->cq_n_elements ; 3936 | } 3937 | 3938 | int tb_bufsize( Cir_Queue_t *CQ ) 3939 | { 3940 | if( !isNul( CQ ) ) 3941 | { 3942 | return (int) CQ-> cq_chunksize ; 3943 | } 3944 | return (int) -1; 3945 | } 3946 | 3947 | void *tb_get( Cir_Queue_t *CQ ) 3948 | { 3949 | int ix ; 3950 | void *rv = (void *) NULL ; 3951 | 3952 | if( !isNul( CQ ) ) 3953 | { 3954 | ix = CQ->cq_next++ ; 3955 | CQ->cq_next = ( CQ->cq_next < CQ->cq_n_elements ) ? CQ->cq_next : 0 ; 3956 | rv = (void *) ( CQ->cq_buffer + ( ix * CQ->cq_chunksize ) ) ; 3957 | str_set( rv, 0, CQ->cq_chunksize ) ; 3958 | } 3959 | return rv ; 3960 | } 3961 | 3962 | #ifdef HOSTED 3963 | Fptr_t it_handler = NULL ; 3964 | void it_doit( int signal ) // ( -- ) 3965 | { 3966 | if( !isNul( it_handler ) ) 3967 | { 3968 | push( it_handler ) ; 3969 | execute() ; 3970 | } 3971 | } 3972 | 3973 | void it_reset() // ( -- ) 3974 | { 3975 | push( 0 ) ; 3976 | push( 0 ) ; 3977 | push( 0 ) ; 3978 | it_set() ; 3979 | } 3980 | 3981 | void it_set() // ( secs usecs pfa -- ) 3982 | { 3983 | struct sigaction action ; 3984 | struct itimerval timer ; 3985 | 3986 | chk( 3 ) ; 3987 | 3988 | memset( &action, 0, sizeof( action ) ) ; 3989 | memset( &timer, 0, sizeof( timer ) ) ; 3990 | 3991 | Wrd_t usec, sec ; 3992 | Fptr_t wordptr ; 3993 | 3994 | it_handler = (Fptr_t) pop() ; 3995 | usec = pop() ; 3996 | sec = pop() ; 3997 | 3998 | action.sa_handler = it_doit ; 3999 | sigaction( SIGALRM, &action, NULL ) ; 4000 | 4001 | timer.it_value.tv_sec = sec ; 4002 | timer.it_value.tv_usec = usec ; 4003 | timer.it_interval.tv_sec = sec ; 4004 | timer.it_interval.tv_usec = usec ; 4005 | if( setitimer( ITIMER_REAL, &timer, NULL ) ) 4006 | throw( err_SysCall ) ; 4007 | 4008 | } 4009 | #endif 4010 | --------------------------------------------------------------------------------