alx/ueforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Re-root site.

Browse Source
This commit is contained in:
Brad Nelson
2022-02-27 20:59:19 -08:00
parent a26786d7ef
commit fb47179999
131 changed files with 27 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
common/all_tests.fs Normal file
View File

@ -0,0 +1,26 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
include common/testing.fs
include common/utils.fs
include common/base_tests.fs
include common/utils_tests.fs
include common/vocabulary_tests.fs
include common/locals_tests.fs
include common/doloop_tests.fs
include common/conditionals_tests.fs
include common/float_tests.fs
include common/forth_namespace_tests.fs
include common/structures_tests.fs
run-tests

33
common/ansi.fs Normal file
View File

@ -0,0 +1,33 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( ANSI Codes )
vocabulary ansi ansi definitions
: esc 27 emit ; : bel 7 emit ;
: clear-to-eol esc ." [0K" ;
: scroll-down esc ." D" ;
: scroll-up esc ." M" ;
: hide esc ." [?25l" ;
: show esc ." [?25h" ;
: terminal-save esc ." [?1049h" ;
: terminal-restore esc ." [?1049l" ;
forth definitions ansi
: fg ( n -- ) esc ." [38;5;" n. ." m" ;
: bg ( n -- ) esc ." [48;5;" n. ." m" ;
: normal esc ." [0m" ;
: at-xy ( x y -- ) esc ." [" 1+ n. ." ;" 1+ n. ." H" ;
: page esc ." [2J" esc ." [H" ;
: set-title ( a n -- ) esc ." ]0;" type bel ;
forth

124
common/base_tests.fs Normal file
View File

@ -0,0 +1,124 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Tests Base Operations )
: test-empty-stack depth 0 =assert ;
: test-add 123 111 + 234 =assert ;
: test-dup-depth 123 depth 1 =assert dup depth 2 =assert 2drop ;
: test-dup-values 456 dup 456 =assert 456 =assert ;
: test-2drop 123 456 2drop depth 0 =assert ;
: test-nip 123 456 nip depth 1 =assert 456 =assert ;
: 8throw 8 throw ;
: test-catch ['] 8throw catch 8 =assert depth 0 =assert ;
: throw-layer 456 >r 123 123 123 8throw 123 123 123 r> ;
: test-catch2 9 ['] throw-layer catch 8 =assert 9 =assert depth 0 =assert ;
: test-rdrop 111 >r 222 >r rdrop r> 111 =assert ;
: test-*/ 1000000 22 7 */ 3142857 =assert ;
: test-bl bl 32 =assert ;
: test-0= 123 0= 0 =assert 0 0= assert ;
: test-cells 123 cells cell+ cell/ 124 =assert ;
: test-aligned 127 aligned 128 =assert ;
: test-[char] [char] * 42 =assert ;
2 3 * 4 * 5 * 6 * 7 * 8 * 9 * 10 * 11 * 12 * constant 2-12*
: test-fornext 1 10 for r@ 2 + * next 2-12* =assert ;
: test-foraft 1 11 for aft r@ 2 + * then next 2-12* =assert ;
: test-doloop 1 13 2 do i * loop 2-12* =assert ;
: inc-times ( a n -- a+n ) 0 ?do 1+ loop ;
: test-?do 123 40 inc-times 163 =assert ;
: test-?do2 123 0 inc-times 123 =assert ;
: test-<> 123 456 <> assert ;
: test-<>2 123 123 <> 0 =assert ;
: inc/2-times ( a n -- a+n/2 ) 0 ?do 1+ 2 +loop ;
: test-+loop 123 0 inc/2-times 123 =assert ;
: test-+loop2 123 6 inc/2-times 126 =assert ;
e: test-arithmetic
3 4 + .
out:\ 7
;e
e: test-print-string
: foo ." This is a test!" cr ;
foo
out: This is a test!
;e
e: test-print20
: foo 20 0 do i . loop cr ;
foo
out: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
;e
e: test-multiline
: foo ." Hello" cr ." There" cr ." Test!" cr ; foo
out: Hello
out: There
out: Test!
;e
e: test-value-to
123 value foo
foo . cr
out: 123
55 to foo
foo . cr
out: 55
: bar 99 to foo ;
foo . cr
out: 55
bar foo . cr
out: 99
;e
e: test-comments-interp
123 ( Interpretered comment ) 456
789 \ Interpretered comment )
789 =assert 456 =assert 123 =assert
;e
e: test-comments-compiled
: foo 123 ( Compiled comment ) 456
789 \ Interpretered comment )
999 ;
foo 999 =assert 789 =assert 456 =assert 123 =assert
;e
e: test-recurse
: factorial dup 0= if drop 1 else dup 1- recurse * then ;
5 factorial 120 =assert
;e
e: test-accept
in: 1234567890xxxxxx
pad 10 accept
pad swap type cr
out: --> 1234567890
out: 1234567890
;e
e: test-key
in: 1
key 49 =assert
key nl =assert
;e
e: test-compiler-off
: test [ 123 111 + literal ] ;
test 234 =assert
;e
e: test-empty-string
: test s" " ;
test 0 =assert drop
;e

75
common/blocks.fs Normal file
View File

@ -0,0 +1,75 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Block Files )
internals definitions
: clobber-line ( a -- a' ) dup 63 blank 63 + nl over c! 1+ ;
: clobber ( a -- ) 15 for clobber-line next drop ;
0 value block-dirty
create block-data 1024 allot
forth definitions internals
-1 value block-fid variable scr -1 value block-id
: open-blocks ( a n -- )
block-fid 0< 0= if block-fid close-file throw -1 to block-fid then
2dup r/w open-file if drop r/w create-file throw else nip nip then to block-fid ;
: use ( "name" -- ) bl parse open-blocks ;
defer default-use
internals definitions
: common-default-use s" blocks.fb" open-blocks ;
' common-default-use is default-use
: use?! block-fid 0< if default-use then ;
: grow-blocks ( n -- ) 1024 * block-fid file-size throw max block-fid resize-file throw ;
forth definitions internals
: save-buffers
block-dirty if
block-id grow-blocks block-id 1024 * block-fid reposition-file throw
block-data 1024 block-fid write-file throw
block-fid flush-file throw
0 to block-dirty
then ;
: block ( n -- a ) use?! dup block-id = if drop block-data exit then
save-buffers dup grow-blocks
dup 1024 * block-fid reposition-file throw
block-data clobber
block-data 1024 block-fid read-file throw drop
to block-id block-data ;
: buffer ( n -- a ) use?! dup block-id = if drop block-data exit then
save-buffers to block-id block-data ;
: empty-buffers -1 to block-id ;
: update -1 to block-dirty ;
: flush save-buffers empty-buffers ;
( Loading )
: load ( n -- ) block 1024 evaluate ;
: thru ( a b -- ) over - 1+ for aft dup >r load r> 1+ then next drop ;
( Utility )
: copy ( from to -- )
swap block pad 1024 cmove pad swap block 1024 cmove update ;
( Editing )
: list ( n -- ) scr ! ." Block " scr @ . cr scr @ block
15 for dup 63 type [char] | emit space 15 r@ - . cr 64 + next drop ;
internals definitions
: @line ( n -- ) 64 * scr @ block + ;
: e' ( n -- ) @line clobber-line drop update ;
forth definitions internals
vocabulary editor also editor definitions
: l scr @ list ; : n 1 scr +! l ; : p -1 scr +! l ;
: wipe 15 for r@ e' next l ; : e e' l ;
: d ( n -- ) dup 1+ @line swap @line 15 @line over - cmove 15 e ;
: r ( n "line" -- ) 0 parse 64 min rot dup e @line swap cmove l ;
: a ( n "line" -- ) dup @line over 1+ @line 16 @line over - cmove> r ;
only forth definitions

198
common/boot.fs Normal file
View File

@ -0,0 +1,198 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
: ( 41 parse drop drop ; immediate
: \ 10 parse drop drop ; immediate
: #! 10 parse drop drop ; immediate ( shebang for scripts )
( Now can do comments! )
( Stack Baseline )
sp@ constant sp0
rp@ constant rp0
fp@ constant fp0
: depth ( -- n ) sp@ sp0 - cell/ ;
: fdepth ( -- n ) fp@ fp0 - 4 / ;
( Useful heap size words )
: remaining ( -- n ) 'heap-start @ 'heap-size @ + 'heap @ - ;
: used ( -- n ) 'heap @ sp@ 'stack-cells @ cells + - 28 + ;
( Compilation State )
: [ 0 state ! ; immediate
: ] -1 state ! ; immediate
( Quoting Words )
: ' bl parse 2dup find dup >r -rot r> 0= 'notfound @ execute 2drop ;
: ['] ' aliteral ; immediate
: char bl parse drop c@ ;
: [char] char aliteral ; immediate
: literal aliteral ; immediate
( Core Control Flow )
: begin here ; immediate
: again ['] branch , , ; immediate
: until ['] 0branch , , ; immediate
: ahead ['] branch , here 0 , ; immediate
: then here swap ! ; immediate
: if ['] 0branch , here 0 , ; immediate
: else ['] branch , here 0 , swap here swap ! ; immediate
: while ['] 0branch , here 0 , swap ; immediate
: repeat ['] branch , , here swap ! ; immediate
: aft drop ['] branch , here 0 , here swap ; immediate
( Recursion )
: recurse current @ @ aliteral ['] execute , ; immediate
( Postpone - done here so we have ['] and IF )
: immediate? ( xt -- f ) >flags 1 and 0= 0= ;
: postpone ' dup immediate? if , else aliteral ['] , , then ; immediate
( Rstack nest depth )
variable nest-depth
( FOR..NEXT )
: for 1 nest-depth +! postpone >r postpone begin ; immediate
: next -1 nest-depth +! postpone donext , ; immediate
( DO..LOOP )
variable leaving
: leaving, here leaving @ , leaving ! ;
: leaving( leaving @ 0 leaving ! 2 nest-depth +! ;
: )leaving leaving @ swap leaving ! -2 nest-depth +!
begin dup while dup @ swap here swap ! repeat drop ;
: (do) ( n n -- .. ) swap r> -rot >r >r >r ;
: do ( lim s -- ) leaving( postpone (do) here ; immediate
: (?do) ( n n -- n n f .. ) 2dup = if 2drop 0 else -1 then ;
: ?do ( lim s -- ) leaving( postpone (?do) postpone 0branch leaving,
postpone (do) here ; immediate
: unloop postpone rdrop postpone rdrop ; immediate
: leave postpone unloop postpone branch leaving, ; immediate
: (+loop) ( n -- f .. ) dup 0< swap r> r> rot + dup r@ < -rot >r >r xor 0= ;
: +loop ( n -- ) postpone (+loop) postpone until
postpone unloop )leaving ; immediate
: loop 1 aliteral postpone +loop ; immediate
: i ( -- n ) postpone r@ ; immediate
: j ( -- n ) rp@ 3 cells - @ ;
( Exceptions )
variable handler
: catch ( xt -- n )
fp@ >r sp@ >r handler @ >r rp@ handler ! execute
r> handler ! rdrop rdrop 0 ;
: throw ( n -- )
dup if handler @ rp! r> handler !
r> swap >r sp! drop r> r> fp! else drop then ;
' throw 'notfound !
( Values )
: value ( n -- ) constant ;
: value-bind ( xt-val xt )
>r >body state @ if
r@ ['] ! = if rdrop ['] doset , , else aliteral r> , then
else r> execute then ;
: to ( n -- ) ' ['] ! value-bind ; immediate
: +to ( n -- ) ' ['] +! value-bind ; immediate
( Deferred Words )
: defer ( "name" -- ) create 0 , does> @ dup 0= throw execute ;
: is ( xt "name -- ) postpone to ; immediate
( Defer I/O to platform specific )
defer type
defer key
defer key?
defer bye
: emit ( n -- ) >r rp@ 1 type rdrop ;
: space bl emit ; : cr nl emit ;
( Numeric Output )
variable hld
: pad ( -- a ) here 80 + ;
: digit ( u -- c ) 9 over < 7 and + 48 + ;
: extract ( n base -- n c ) u/mod swap digit ;
: <# ( -- ) pad hld ! ;
: hold ( c -- ) hld @ 1 - dup hld ! c! ;
: # ( u -- u ) base @ extract hold ;
: #s ( u -- 0 ) begin # dup while repeat ;
: sign ( n -- ) 0< if 45 hold then ;
: #> ( w -- b u ) drop hld @ pad over - ;
: str ( n -- b u ) dup >r abs <# #s r> sign #> ;
: hex ( -- ) 16 base ! ; : octal ( -- ) 8 base ! ;
: decimal ( -- ) 10 base ! ; : binary ( -- ) 2 base ! ;
: u. ( u -- ) <# #s #> type space ;
: . ( w -- ) base @ 10 xor if u. exit then str type space ;
: ? ( a -- ) @ . ;
: n. ( n -- ) base @ swap decimal <# #s #> type base ! ;
( Strings )
: parse-quote ( -- a n ) [char] " parse ;
: $place ( a n -- ) for aft dup c@ c, 1+ then next drop ;
: zplace ( a n -- ) $place 0 c, align ;
: $@ r@ dup cell+ swap @ r> dup @ 1+ aligned + cell+ >r ;
: s" parse-quote state @ if postpone $@ dup , zplace
else dup here swap >r >r zplace r> r> then ; immediate
: ." postpone s" state @ if postpone type else type then ; immediate
: z" postpone s" state @ if postpone drop else drop then ; immediate
: r" parse-quote state @ if swap aliteral aliteral then ; immediate
: r| [char] | parse state @ if swap aliteral aliteral then ; immediate
: r~ [char] ~ parse state @ if swap aliteral aliteral then ; immediate
: s>z ( a n -- z ) here >r zplace r> ;
: z>s ( z -- a n ) 0 over begin dup c@ while 1+ swap 1+ swap repeat drop ;
( Better Errors )
: notfound ( a n n -- )
if cr ." ERROR: " type ." NOT FOUND!" cr -1 throw then ;
' notfound 'notfound !
( Input )
: raw.s depth 0 max for aft sp@ r@ cells - @ . then next ;
variable echo -1 echo ! variable arrow -1 arrow !
: ?echo ( n -- ) echo @ if emit else drop then ;
: ?arrow. arrow @ if >r >r raw.s r> r> ." --> " then ;
: accept ( a n -- n ) ?arrow. 0 swap begin 2dup < while
key
dup nl = over 13 = or if ?echo drop nip exit then
dup 8 = over 127 = or if
drop over if rot 1- rot 1- rot 8 ?echo bl ?echo 8 ?echo then
else
dup ?echo
>r rot r> over c! 1+ -rot swap 1+ swap
then
repeat drop nip
( Eat rest of the line if buffer too small )
begin key dup nl = over 13 = or if ?echo exit else drop then again
;
200 constant input-limit
: tib ( -- a ) 'tib @ ;
create input-buffer input-limit allot
: tib-setup input-buffer 'tib ! ;
: refill tib-setup tib input-limit accept #tib ! 0 >in ! -1 ;
( REPL )
: prompt ." ok" cr ;
: evaluate-buffer begin >in @ #tib @ < while evaluate1 repeat ;
: evaluate ( a n -- ) 'tib @ >r #tib @ >r >in @ >r
#tib ! 'tib ! 0 >in ! evaluate-buffer
r> >in ! r> #tib ! r> 'tib ! ;
: quit begin ['] evaluate-buffer catch
if 0 state ! sp0 sp! fp0 fp! rp0 rp! ." ERROR" cr then
prompt refill drop again ;
variable boot-prompt
: free. ( nf nu -- ) 2dup swap . ." free + " . ." used = " 2dup + . ." total ("
over + 100 -rot */ n. ." % free)" ;
: raw-ok ." v{{VERSION}} - rev {{REVISION}}" cr
boot-prompt @ if boot-prompt @ execute then
." Forth dictionary: " remaining used free. cr
." 3 x Forth stacks: " 'stack-cells @ cells . ." bytes each" cr
prompt refill drop quit ;

57
common/calling.h Normal file
View File

@ -0,0 +1,57 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#define SET tos = (cell_t)
#define n0 tos
#define n1 (*sp)
#define n2 sp[-1]
#define n3 sp[-2]
#define n4 sp[-3]
#define n5 sp[-4]
#define n6 sp[-5]
#define n7 sp[-6]
#define n8 sp[-7]
#define n9 sp[-8]
#define n10 sp[-9]
#define n11 sp[-10]
#define n12 sp[-11]
#define n13 sp[-12]
#define n14 sp[-13]
#define n15 sp[-14]
#define a0 ((void *) tos)
#define a1 (*(void **) &n1)
#define a2 (*(void **) &n2)
#define a3 (*(void **) &n3)
#define a4 (*(void **) &n4)
#define a5 (*(void **) &n5)
#define a6 (*(void **) &n6)
#define b0 ((uint8_t *) tos)
#define b1 (*(uint8_t **) &n1)
#define b2 (*(uint8_t **) &n2)
#define b3 (*(uint8_t **) &n3)
#define b4 (*(uint8_t **) &n4)
#define b5 (*(uint8_t **) &n5)
#define b6 (*(uint8_t **) &n6)
#define c0 ((char *) tos)
#define c1 (*(char **) &n1)
#define c2 (*(char **) &n2)
#define c3 (*(char **) &n3)
#define c4 (*(char **) &n4)
#define c5 (*(char **) &n5)
#define c6 (*(char **) &n6)

43
common/calls.h Normal file
View File

@ -0,0 +1,43 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#ifndef CALLTYPE
# define CALLTYPE
#endif
#ifdef __cplusplus
typedef cell_t (CALLTYPE *call_t)(...);
#else
typedef cell_t (CALLTYPE *call_t)();
#endif
#define ct0 ((call_t) n0)
#define CALLING_OPCODE_LIST \
YV(internals, CALL0, n0 = ct0()) \
YV(internals, CALL1, n0 = ct0(n1); --sp) \
YV(internals, CALL2, n0 = ct0(n2, n1); sp -= 2) \
YV(internals, CALL3, n0 = ct0(n3, n2, n1); sp -= 3) \
YV(internals, CALL4, n0 = ct0(n4, n3, n2, n1); sp -= 4) \
YV(internals, CALL5, n0 = ct0(n5, n4, n3, n2, n1); sp -= 5) \
YV(internals, CALL6, n0 = ct0(n6, n5, n4, n3, n2, n1); sp -= 6) \
YV(internals, CALL7, n0 = ct0(n7, n6, n5, n4, n3, n2, n1); sp -= 7) \
YV(internals, CALL8, n0 = ct0(n8, n7, n6, n5, n4, n3, n2, n1); sp -= 8) \
YV(internals, CALL9, n0 = ct0(n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 9) \
YV(internals, CALL10, n0 = ct0(n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 10) \
YV(internals, CALL11, n0 = ct0(n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 11) \
YV(internals, CALL12, n0 = ct0(n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 12) \
YV(internals, CALL13, n0 = ct0(n13, n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 13) \
YV(internals, CALL14, n0 = ct0(n14, n13, n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 14) \
YV(internals, CALL15, n0 = ct0(n15, n14, n13, n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 15)

26
common/conditionals.fs Normal file
View File

@ -0,0 +1,26 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Interpret time conditionals )
: DEFINED? ( "name" -- xt|0 )
bl parse find state @ if aliteral then ; immediate
defer [SKIP]
: [THEN] ; : [ELSE] [SKIP] ; : [IF] 0= if [SKIP] then ;
: [SKIP]' 0 begin postpone defined? dup if
dup ['] [IF] = if swap 1+ swap then
dup ['] [ELSE] = if swap dup 0 <= if 2drop exit then swap then
dup ['] [THEN] = if swap 1- dup 0< if 2drop exit then swap then
then drop again ;
' [SKIP]' is [SKIP]

80
common/conditionals_tests.fs Normal file
View File

@ -0,0 +1,80 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Interpret time conditionals )
e: test-1[if]
1 [IF]
: test ." hi" cr ;
[THEN]
test
out: hi
;e
e: test-0[if]
: test ." initial" cr ;
0 [IF]
: test ." hi" cr ;
[THEN]
test
out: initial
;e
e: test-1[if][else]
1 [IF]
: test ." hi" cr ;
[ELSE]
: test ." there" cr ;
[THEN]
test
out: hi
;e
e: test-0[if][else]
0 [IF]
: test ." hi" cr ;
[ELSE]
: test ." there" cr ;
[THEN]
test
out: there
;e
e: test-1[if]-nesting
1 [IF]
: test ." foo" cr ;
[ELSE]
1 [IF]
: test ." bar" cr ;
[ELSE]
: test ." baz" cr ;
[THEN]
[THEN]
test
out: foo
;e
e: test-0[if]-nesting
0 [IF]
1 [IF]
: test ." foo" cr ;
[ELSE]
: test ." bar" cr ;
[THEN]
[ELSE]
: test ." baz" cr ;
[THEN]
test
out: baz
;e

291
common/core.h Normal file
View File

@ -0,0 +1,291 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#define PRINT_ERRORS 0
#define CELL_MASK (sizeof(cell_t) - 1)
#define CELL_LEN(n) (((n) + CELL_MASK) / sizeof(cell_t))
#define FIND(name) find((name), sizeof(name) - 1)
#define UPPER(ch) (((ch) >= 'a' && (ch) <= 'z') ? ((ch) & 0x5F) : (ch))
#define CELL_ALIGNED(a) ((((cell_t) (a)) + CELL_MASK) & ~CELL_MASK)
#define IMMEDIATE 1
#define SMUDGE 2
#define BUILTIN_FORK 4
#define BUILTIN_MARK 8
// Maximum ALSO layers.
#define VOCABULARY_DEPTH 16
#if PRINT_ERRORS
#include <stdio.h>
#endif
enum {
#define V(name) VOC_ ## name,
VOCABULARY_LIST
#undef V
};
enum {
#define V(name) VOC_ ## name ## _immediate = VOC_ ## name + (IMMEDIATE << 8),
VOCABULARY_LIST
#undef V
};
static struct {
cell_t *heap, **current, ***context;
cell_t *latestxt, notfound;
cell_t *heap_start;
cell_t heap_size, stack_cells;
const char *boot;
cell_t boot_size;
const char *tib;
cell_t ntib, tin, state, base;
int argc;
char **argv;
cell_t *(*runner)(cell_t *rp); // pointer to forth_run
// Layout not used by Forth.
cell_t *rp; // spot to park main thread
cell_t DOLIT_XT, DOFLIT_XT, DOEXIT_XT, YIELD_XT;
void *DOCREATE_OP;
const BUILTIN_WORD *builtins;
} g_sys;
static cell_t convert(const char *pos, cell_t n, cell_t base, cell_t *ret) {
*ret = 0;
cell_t negate = 0;
if (!n) { return 0; }
if (*pos == '-') { negate = -1; ++pos; --n; }
if (*pos == '$') { base = 16; ++pos; --n; }
for (; n; --n) {
uintptr_t d = UPPER(*pos) - '0';
if (d > 9) {
d -= 7;
if (d < 10) { return 0; }
}
if (d >= (uintptr_t) base) { return 0; }
*ret = *ret * base + d;
++pos;
}
if (negate) { *ret = -*ret; }
return -1;
}
static cell_t fconvert(const char *pos, cell_t n, float *ret) {
*ret = 0;
cell_t negate = 0;
cell_t has_dot = 0;
cell_t exp = 0;
float shift = 1.0;
if (!n) { return 0; }
if (*pos == '-') { negate = -1; ++pos; --n; }
for (; n; --n) {
if (*pos >= '0' && *pos <= '9') {
if (has_dot) {
shift = shift * 0.1f;
*ret = *ret + (*pos - '0') * shift;
} else {
*ret = *ret * 10 + (*pos - '0');
}
} else if (*pos == 'e' || *pos == 'E') {
break;
} else if (*pos == '.') {
if (has_dot) { return 0; }
has_dot = -1;
} else {
return 0;
}
++pos;
}
if (!n) { return 0; } // must have E
++pos; --n;
if (n) {
if (!convert(pos, n, 10, &exp)) { return 0; }
}
if (exp < -128 || exp > 128) { return 0; }
for (;exp < 0; ++exp) { *ret *= 0.1f; }
for (;exp > 0; --exp) { *ret *= 10.0f; }
if (negate) { *ret = -*ret; }
return -1;
}
static cell_t same(const char *a, const char *b, cell_t len) {
for (;len && UPPER(*a) == UPPER(*b); --len, ++a, ++b);
return len == 0;
}
static cell_t find(const char *name, cell_t len) {
for (cell_t ***voc = g_sys.context; *voc; ++voc) {
cell_t xt = (cell_t) **voc;
while (xt) {
if ((*TOFLAGS(xt) & BUILTIN_FORK)) {
cell_t vocab = TOLINK(xt)[3];
for (int i = 0; g_sys.builtins[i].name; ++i) {
if (g_sys.builtins[i].vocabulary == vocab &&
len == g_sys.builtins[i].name_length &&
same(name, g_sys.builtins[i].name, len)) {
return (cell_t) &g_sys.builtins[i].code;
}
}
}
if (!(*TOFLAGS(xt) & SMUDGE) && len == *TONAMELEN(xt) &&
same(name, TONAME(xt), len)) {
return xt;
}
xt = *TOLINK(xt);
}
}
return 0;
}
static void finish(void) {
if (g_sys.latestxt && !*TOPARAMS(g_sys.latestxt)) {
cell_t sz = g_sys.heap - &g_sys.latestxt[1];
if (sz < 0 || sz > 0xffff) { sz = 0xffff; }
*TOPARAMS(g_sys.latestxt) = sz;
}
}
static void create(const char *name, cell_t nlength, cell_t flags, void *op) {
finish();
g_sys.heap = (cell_t *) CELL_ALIGNED(g_sys.heap);
char *pos = (char *) g_sys.heap;
for (cell_t n = nlength; n; --n) { *pos++ = *name++; } // name
g_sys.heap += CELL_LEN(nlength);
*g_sys.heap++ = (cell_t) *g_sys.current; // link
*g_sys.heap++ = (nlength << 8) | flags; // flags & length
*g_sys.current = g_sys.heap;
g_sys.latestxt = g_sys.heap;
*g_sys.heap++ = (cell_t) op; // code
}
static int match(char sep, char ch) {
return sep == ch || (sep == ' ' && (ch == '\t' || ch == '\n' || ch == '\r'));
}
static cell_t parse(cell_t sep, cell_t *ret) {
if (sep == ' ') {
while (g_sys.tin < g_sys.ntib &&
match(sep, g_sys.tib[g_sys.tin])) { ++g_sys.tin; }
}
*ret = (cell_t) (g_sys.tib + g_sys.tin);
while (g_sys.tin < g_sys.ntib &&
!match(sep, g_sys.tib[g_sys.tin])) { ++g_sys.tin; }
cell_t len = g_sys.tin - (*ret - (cell_t) g_sys.tib);
if (g_sys.tin < g_sys.ntib) { ++g_sys.tin; }
return len;
}
static cell_t *evaluate1(cell_t *sp, float **fp) {
cell_t call = 0;
cell_t name;
cell_t len = parse(' ', &name);
if (len == 0) { *++sp = 0; return sp; } // ignore empty
cell_t xt = find((const char *) name, len);
if (xt) {
if (g_sys.state && !(((cell_t *) xt)[-1] & IMMEDIATE)) {
*g_sys.heap++ = xt;
} else {
call = xt;
}
} else {
cell_t n;
if (convert((const char *) name, len, g_sys.base, &n)) {
if (g_sys.state) {
*g_sys.heap++ = g_sys.DOLIT_XT;
*g_sys.heap++ = n;
} else {
*++sp = n;
}
} else {
float f;
if (fconvert((const char *) name, len, &f)) {
if (g_sys.state) {
*g_sys.heap++ = g_sys.DOFLIT_XT;
*(float *) g_sys.heap++ = f;
} else {
*++(*fp) = f;
}
} else {
#if PRINT_ERRORS
fprintf(stderr, "CANT FIND: ");
fwrite((void *) name, 1, len, stderr);
fprintf(stderr, "\n");
#endif
*++sp = name;
*++sp = len;
*++sp = -1;
call = g_sys.notfound;
}
}
}
*++sp = call;
return sp;
}
static cell_t *forth_run(cell_t *initrp);
static void forth_init(int argc, char *argv[],
void *heap, cell_t heap_size,
const char *src, cell_t src_len) {
g_sys.heap_start = (cell_t *) heap;
g_sys.heap_size = heap_size;
g_sys.stack_cells = STACK_CELLS;
g_sys.boot = src;
g_sys.boot_size = src_len;
g_sys.heap = g_sys.heap_start + 4; // Leave a little room.
float *fp = (float *) (g_sys.heap + 1); g_sys.heap += STACK_CELLS;
cell_t *rp = g_sys.heap + 1; g_sys.heap += STACK_CELLS;
cell_t *sp = g_sys.heap + 1; g_sys.heap += STACK_CELLS;
// FORTH worldlist (relocated when vocabularies added).
cell_t *forth_wordlist = g_sys.heap;
*g_sys.heap++ = 0;
// Vocabulary stack
g_sys.current = (cell_t **) forth_wordlist;
g_sys.context = (cell_t ***) g_sys.heap;
g_sys.latestxt = 0;
*g_sys.heap++ = (cell_t) forth_wordlist;
for (int i = 0; i < VOCABULARY_DEPTH; ++i) { *g_sys.heap++ = 0; }
forth_run(0);
#define V(name) \
create(#name "-builtins", sizeof(#name "-builtins") - 1, \
BUILTIN_FORK, g_sys.DOCREATE_OP); \
*g_sys.heap++ = VOC_ ## name;
VOCABULARY_LIST
#undef V
g_sys.latestxt = 0; // So last builtin doesn't get wrong size.
g_sys.DOLIT_XT = FIND("DOLIT");
g_sys.DOFLIT_XT = FIND("DOFLIT");
g_sys.DOEXIT_XT = FIND("EXIT");
g_sys.YIELD_XT = FIND("YIELD");
g_sys.notfound = FIND("DROP");
cell_t *start = g_sys.heap;
*g_sys.heap++ = FIND("EVALUATE1");
*g_sys.heap++ = FIND("BRANCH");
*g_sys.heap++ = (cell_t) start;
g_sys.argc = argc;
g_sys.argv = argv;
g_sys.base = 10;
g_sys.tib = src;
g_sys.ntib = src_len;
*++rp = (cell_t) fp;
*++rp = (cell_t) sp;
*++rp = (cell_t) start;
g_sys.rp = rp;
g_sys.runner = forth_run;
}

25
common/desktop.fs Normal file
View File

@ -0,0 +1,25 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
forth definitions internals
: argc ( -- n ) 'argc @ ;
: argv ( n -- a n ) cells 'argv @ + @ z>s ;
internals definitions also ansi
: boot-set-title s" uEforth" set-title ;
' boot-set-title boot-prompt !
only forth definitions

132
common/doloop_tests.fs Normal file
View File

@ -0,0 +1,132 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Test DO LOOP Works )
e: test-0doloop
: foo 0 do i . loop cr ;
10 foo
out: 0 1 2 3 4 5 6 7 8 9
;e
e: test-0?do-loop
: foo 0 ?do i . loop cr ;
10 foo
out: 0 1 2 3 4 5 6 7 8 9
0 foo
out:
;e
e: test-rev-doloop
: foo 0 10 do i . -1 +loop cr ;
foo
out: 10 9 8 7 6 5 4 3 2 1 0
;e
e: test-rev-?doloop
: foo 0 10 ?do i . -1 +loop cr ;
foo
out: 10 9 8 7 6 5 4 3 2 1 0
;e
e: test-do+loop
: foo 0 do i . 2 +loop cr ;
9 foo
out: 0 2 4 6 8
10 foo
out: 0 2 4 6 8
11 foo
out: 0 2 4 6 8 10
1 foo
out: 0
;e
e: test-?do+loop
: foo 0 ?do i . 2 +loop cr ;
9 foo
out: 0 2 4 6 8
10 foo
out: 0 2 4 6 8
11 foo
out: 0 2 4 6 8 10
1 foo
out: 0
0 foo
out:
;e
e: test-doloop-leave
: foo 0 do 42 emit i 7 = if ." left " leave ." nope" then i . loop cr ;
7 foo
out: *0 *1 *2 *3 *4 *5 *6
8 foo
out: *0 *1 *2 *3 *4 *5 *6 *left
9 foo
out: *0 *1 *2 *3 *4 *5 *6 *left
;e
e: test-do+loop-leave
: foo 0 do 42 emit i 8 = if ." left " leave ." nope" then i . 2 +loop cr ;
7 foo
out: *0 *2 *4 *6
8 foo
out: *0 *2 *4 *6
9 foo
out: *0 *2 *4 *6 *left
0 foo
out: *0
;e
e: test-?do+loop-leave
: foo 0 ?do 42 emit i 8 = if ." left " leave ." nope" then i . 2 +loop cr ;
7 foo
out: *0 *2 *4 *6
8 foo
out: *0 *2 *4 *6
9 foo
out: *0 *2 *4 *6 *left
0 foo
out:
;e
e: test-do+loop-unloop
: foo 0 do 42 emit i 8 = if ." left " cr unloop exit then i . 2 +loop ." done " cr ;
7 foo
out: *0 *2 *4 *6 done
8 foo
out: *0 *2 *4 *6 done
9 foo
out: *0 *2 *4 *6 *left
0 foo
out: *0 done
;e
e: test-?do+loop-unloop
: foo 0 ?do 42 emit i 8 = if ." left " cr unloop exit then i . 2 +loop ." done " cr ;
7 foo
out: *0 *2 *4 *6 done
8 foo
out: *0 *2 *4 *6 done
9 foo
out: *0 *2 *4 *6 *left
0 foo
out: done
;e
e: test-doloop-j
: foo 5 0 do 3 0 do j . loop loop cr ;
foo
out: 0 0 0 1 1 1 2 2 2 3 3 3 4 4 4
;e

19
common/editor.fs Normal file
View File

@ -0,0 +1,19 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
include posix/termios.fs
create keymap
: edit raw-mode begin key . again ;

106
common/extra.fs Normal file
View File

@ -0,0 +1,106 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Useful Basic Compound Words )
: nip ( a b -- b ) swap drop ;
: rdrop ( r: n n -- ) r> r> drop >r ;
: */ ( n n n -- n ) */mod nip ;
: * ( n n -- n ) 1 */ ;
: /mod ( n n -- n n ) 1 swap */mod ;
: / ( n n -- n ) /mod nip ;
: mod ( n n -- n ) /mod drop ;
: invert ( n -- ~n ) -1 xor ;
: negate ( n -- -n ) invert 1 + ;
: - ( n n -- n ) negate + ;
: rot ( a b c -- c a b ) >r swap r> swap ;
: -rot ( a b c -- b c a ) swap >r swap r> ;
: < ( a b -- a<b ) - 0< ;
: > ( a b -- a>b ) swap - 0< ;
: <= ( a b -- a>b ) swap - 0< 0= ;
: >= ( a b -- a<b ) - 0< 0= ;
: = ( a b -- a!=b ) - 0= ;
: <> ( a b -- a!=b ) = 0= ;
: 0<> ( n -- n) 0= 0= ;
: bl 32 ; : nl 10 ;
: 1+ 1 + ; : 1- 1 - ;
: 2* 2 * ; : 2/ 2 / ;
: 4* 4 * ; : 4/ 4 / ;
: +! ( n a -- ) swap over @ + swap ! ;
( Cells )
: cell+ ( n -- n ) cell + ;
: cells ( n -- n ) cell * ;
: cell/ ( n -- n ) cell / ;
( Double Words )
: 2drop ( n n -- ) drop drop ;
: 2dup ( a b -- a b a b ) over over ;
: 2@ ( a -- lo hi ) dup @ swap cell+ @ ;
: 2! ( lo hi a -- ) dup >r cell+ ! r> ! ;
( Fill, Move )
: cmove ( a a n -- ) for aft >r dup c@ r@ c! 1+ r> 1+ then next 2drop ;
: cmove> ( a a n -- ) for aft 2dup swap r@ + c@ swap r@ + c! then next 2drop ;
: fill ( a n ch -- ) swap for swap aft 2dup c! 1 + then next 2drop ;
: erase ( a n -- ) 0 fill ; : blank ( a n -- ) bl fill ;
( Compound words requiring conditionals )
: min 2dup < if drop else nip then ;
: max 2dup < if nip else drop then ;
: abs ( n -- +n ) dup 0< if negate then ;
( Dictionary )
: here ( -- a ) 'sys @ ;
: allot ( n -- ) 'sys +! ;
: aligned ( a -- a ) cell 1 - dup >r + r> invert and ;
: align here aligned here - allot ;
: , ( n -- ) here ! cell allot ;
: c, ( ch -- ) here c! 1 allot ;
( Dictionary Format )
: >flags& ( xt -- a ) cell - ; : >flags ( xt -- flags ) >flags& c@ ;
: >name-length ( xt -- n ) >flags& 1+ c@ ;
: >params ( xt -- n ) >flags& 2 + sw@ $ffff and ;
: >size ( xt -- n ) dup >params cells swap >name-length aligned + 3 cells + ;
: >link& ( xt -- a ) 2 cells - ; : >link ( xt -- a ) >link& @ ;
: >name ( xt -- a n ) dup >name-length swap >link& over aligned - swap ;
: >body ( xt -- a ) dup @ [ ' >flags @ ] literal = 2 + cells + ;
( System Variables )
: sys: ( a -- a' "name" ) dup constant cell+ ;
'sys sys: 'heap sys: current sys: 'context
sys: 'latestxt sys: 'notfound
sys: 'heap-start sys: 'heap-size sys: 'stack-cells
sys: 'boot sys: 'boot-size
sys: 'tib sys: #tib sys: >in
sys: state sys: base
sys: 'argc sys: 'argv sys: 'runner
: context ( -- a ) 'context @ cell+ ;
: latestxt ( -- xt ) 'latestxt @ ;
: f= ( r r -- f ) f- f0= ;
: f< ( r r -- f ) f- f0< ;
: f> ( r r -- f ) fswap f< ;
: f<> ( r r -- f ) f= 0= ;
: f<= ( r r -- f ) f> 0= ;
: f>= ( r r -- f ) f< 0= ;
4 constant sfloat
: sfloats ( n -- n*4 ) sfloat * ;
: sfloat+ ( a -- a ) sfloat + ;
3.14159265359e fconstant pi
: fsqrt ( r -- r ) 1e 20 0 do fover fover f/ f+ 0.5e f* loop fnip ;

96
common/extra_opcodes.h Normal file
View File

@ -0,0 +1,96 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#define EXTRA_OPCODE_LIST \
Y(nip, NIP) \
Y(rdrop, --rp) \
X("*/", STARSLASH, SSMOD_FUNC; NIP) \
X("*", STAR, tos *= *sp--) \
X("/mod", SLASHMOD, DUP; *sp = 1; SSMOD_FUNC) \
X("/", SLASH, DUP; *sp = 1; SSMOD_FUNC; NIP) \
Y(mod, DUP; *sp = 1; SSMOD_FUNC; DROP) \
Y(invert, tos = ~tos) \
Y(negate, tos = -tos) \
X("-", MINUS, tos = (*sp--) - tos) \
Y(rot, w = sp[-1]; sp[-1] = *sp; *sp = tos; tos = w) \
X("-rot", MROT, w = tos; tos = *sp; *sp = sp[-1]; sp[-1] = w) \
X("<", LESS, tos = (*sp--) < tos ? -1 : 0) \
X(">", GREATER, tos = (*sp--) > tos ? -1 : 0) \
X("<=", LESSEQ, tos = (*sp--) <= tos ? -1 : 0) \
X(">=", GREATEREQ, tos = (*sp--) >= tos ? -1 : 0) \
X("=", EQUAL, tos = (*sp--) == tos ? -1 : 0) \
X("<>", NOTEQUAL, tos = (*sp--) != tos ? -1 : 0) \
X("0<>", ZNOTEQUAL, tos = tos ? -1 : 0) \
Y(bl, DUP; tos = ' ') \
Y(nl, DUP; tos = '\n') \
X("1+", ONEPLUS, ++tos) \
X("1-", ONEMINUS, --tos) \
X("2*", TWOSTAR, tos <<= 1) \
X("2/", TWOSLASH, tos >>= 1) \
X("4*", FOURSTAR, tos <<= 2) \
X("4/", FOURSLASH, tos >>= 2) \
X("+!", PLUSSTORE, *(cell_t *) tos += *sp--; DROP) \
X("cell+", CELLPLUS, tos += sizeof(cell_t)) \
X("cells", CELLSTAR, tos *= sizeof(cell_t)) \
X("cell/", CELLSLASH, DUP; tos = sizeof(cell_t); DUP; *sp = 1; SSMOD_FUNC; NIP) \
X("2drop", TWODROP, NIP; DROP) \
X("2dup", TWODUP, DUP; tos = sp[-1]; DUP; tos = sp[-1]) \
X("2@", TWOAT, DUP; *sp = ((cell_t *) tos)[1]; tos = *(cell_t *) tos) \
X("2!", TWOSTORE, DUP; ((cell_t *) tos)[0] = sp[-1]; \
((cell_t *) tos)[1] = *sp; sp -= 2; DROP) \
Y(cmove, memmove((void *) *sp, (void *) sp[-1], tos); sp -= 2; DROP) \
X("cmove>", cmove2, memmove((void *) *sp, (void *) sp[-1], tos); sp -= 2; DROP) \
Y(fill, memset((void *) sp[-1], tos, *sp); sp -= 2; DROP) \
Y(erase, memset((void *) *sp, 0, tos); NIP; DROP) \
Y(blank, memset((void *) *sp, ' ', tos); NIP; DROP) \
Y(min, tos = tos < *sp ? tos : *sp; NIP) \
Y(max, tos = tos > *sp ? tos : *sp; NIP) \
Y(abs, tos = tos < 0 ? -tos : tos) \
Y(here, DUP; tos = (cell_t) g_sys.heap) \
Y(allot, g_sys.heap = (cell_t *) (tos + (cell_t) g_sys.heap); DROP) \
Y(aligned, tos = CELL_ALIGNED(tos)) \
Y(align, g_sys.heap = (cell_t *) CELL_ALIGNED(g_sys.heap)) \
X(",", COMMA, *g_sys.heap++ = tos; DROP) \
X("c,", CCOMMA, *((uint8_t *) g_sys.heap) = tos; DROP; \
g_sys.heap = (cell_t *) (1 + ((cell_t) g_sys.heap))) \
X(">flags", TOFLAGS, tos = *TOFLAGS(tos)) \
X(">params", TOPARAMS, tos = *TOPARAMS(tos)) \
X(">size", TOSIZE, tos = TOSIZE(tos)) \
X(">link&", TOLINKAT, tos = (cell_t) TOLINK(tos)) \
X(">link", TOLINK, tos = *TOLINK(tos)) \
X(">name", TONAME, DUP; *sp = (cell_t) TONAME(tos); tos = *TONAMELEN(tos)) \
X(">body", TOBODY, tos = (cell_t) TOBODY(tos)) \
XV(internals, "'heap", THEAP, DUP; tos = (cell_t) &g_sys.heap) \
Y(current, DUP; tos = (cell_t) &g_sys.current) \
XV(internals, "'context", TCONTEXT, DUP; tos = (cell_t) &g_sys.context) \
XV(internals, "'latestxt", TLATESTXT, DUP; tos = (cell_t) &g_sys.latestxt) \
XV(internals, "'notfound", TNOTFOUND, DUP; tos = (cell_t) &g_sys.notfound) \
XV(internals, "'heap-start", THEAP_START, DUP; tos = (cell_t) &g_sys.heap_start) \
XV(internals, "'heap-size", THEAP_SIZE, DUP; tos = (cell_t) &g_sys.heap_size) \
XV(internals, "'stack-cells", TSTACK_CELLS, DUP; tos = (cell_t) &g_sys.stack_cells) \
XV(internals, "'boot", TBOOT, DUP; tos = (cell_t) &g_sys.boot) \
XV(internals, "'boot-size", TBOOT_SIZE, DUP; tos = (cell_t) &g_sys.boot_size) \
XV(internals, "'tib", TTIB, DUP; tos = (cell_t) &g_sys.tib) \
X("#tib", NTIB, DUP; tos = (cell_t) &g_sys.ntib) \
X(">in", TIN, DUP; tos = (cell_t) &g_sys.tin) \
Y(state, DUP; tos = (cell_t) &g_sys.state) \
Y(base, DUP; tos = (cell_t) &g_sys.base) \
XV(internals, "'argc", ARGC, DUP; tos = (cell_t) &g_sys.argc) \
XV(internals, "'argv", ARGV, DUP; tos = (cell_t) &g_sys.argv) \
XV(internals, "'runner", RUNNER, DUP; tos = (cell_t) &g_sys.runner) \
YV(internals, fill32, cell_t c = tos; DROP; cell_t n = tos; DROP; \
uint32_t *a = (uint32_t *) tos; DROP; \
for (;n;--n) *a++ = c) \
Y(context, DUP; tos = (cell_t) (g_sys.context + 1)) \
Y(latestxt, DUP; tos = (cell_t) g_sys.latestxt)

60
common/filetools.fs Normal file
View File

@ -0,0 +1,60 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
: dump-file ( a n a n -- )
w/o create-file if drop ." failed create-file" exit then
>r r@ write-file if r> drop ." failed write-file" exit then
r> close-file drop
;
internals definitions
( Leave some room for growth of starting system. )
0 value saving-base
: park-heap ( -- a ) saving-base ;
: park-forth ( -- a ) saving-base cell+ ;
: 'cold ( -- a ) saving-base 2 cells + ;
: setup-saving-base
here to saving-base 16 cells allot 0 'cold ! ;
' forth >body constant forth-wordlist
: save-name
'heap @ park-heap !
forth-wordlist @ park-forth !
w/o create-file throw >r
saving-base here over - r@ write-file throw
r> close-file throw ;
: restore-name ( "name" -- )
r/o open-file throw >r
saving-base r@ file-size throw r@ read-file throw drop
r> close-file throw
park-heap @ 'heap !
park-forth @ forth-wordlist !
'cold @ dup if execute else drop then ;
defer remember-filename
: default-remember-filename s" myforth" ;
' default-remember-filename is remember-filename
forth definitions also internals
: save ( "name" -- ) bl parse save-name ;
: restore ( "name" -- ) bl parse restore-name ;
: remember remember-filename save-name ;
: startup: ( "name" ) ' 'cold ! remember ;
: revive remember-filename restore-name ;
: reset remember-filename delete-file throw ;
only forth definitions

25
common/fini.fs Normal file
View File

@ -0,0 +1,25 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
internals definitions
( TODO: Figure out why this has to happen so late. )
transfer internals-builtins
forth definitions internals
( Bring a forth to the top of the vocabulary. )
transfer forth
( Move heap to save point, with a gap. )
setup-saving-base
forth
execute ( assumes an xt for autoboot is on the dstack )
ok

106
common/float_tests.fs Normal file
View File

@ -0,0 +1,106 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
e: test-f.
123e f. cr
out: 123.000000
123.123e f. cr
out: 123.123000
-123.123e f. cr
out: -123.123000
;e
e: test-f+
123e 11e f+ f. cr
out: 134.000000
;e
e: test-f*
123e 10e f* f. cr
out: 1230.000000
;e
e: test-1/f
100e 1/f f. cr
out: 0.009999
;e
e: test-f/
1000e 4e f/ f. cr
out: 250.000000
;e
e: test-fsqrt
256e fsqrt f. cr
out: 16.000000
;e
e: test-fswap
123e 234e fswap f. f. cr
out: 123.000000 234.000000
;e
e: test-fover
123e 234e fover f. f. f. cr
out: 123.000000 234.000000 123.000000
;e
e: test-throw
: bar 123e 124e 125e 1 throw ;
: foo 99e ['] bar catch . f. ;
foo cr
out: 1 99.000000
;e
e: test-fconstant
100e fconstant foo
foo f. cr
out: 100.000000
;e
e: test-fvariable
fvariable foo
10e foo sf!
foo sf@ fdup f* foo sf!
foo sf@ f. cr
out: 100.000000
;e
e: test-fcompare
123e 245e f< assert
123e 66e f> assert
123e 123e f>= assert
124e 123e f>= assert
123e 123e f<= assert
123e 124e f<= assert
123e 124e f<> assert
123e 123e f= assert
;e
e: test-fliteral
: foo [ 123e ] fliteral f. cr ;
foo
out: 123.000000
;e
e: test-afliteral
: foo [ 123e afliteral ] f. cr ;
foo
out: 123.000000
;e
e: test-float-broken-parse
internals
s" teste" f>number? 0= assert
;e

37
common/floats.fs Normal file
View File

@ -0,0 +1,37 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
: sf, ( r -- ) here sf! sfloat allot ;
: afliteral ( r -- ) ['] DOFLIT , sf, align ;
: fliteral afliteral ; immediate
: fconstant ( r "name" ) create sf, align does> sf@ ;
: fvariable ( "name" ) create sfloat allot align ;
6 value precision
: set-precision ( n -- ) to precision ;
internals definitions
: #f+s ( r -- ) fdup precision 0 ?do 10e f* loop
precision 0 ?do fdup f>s 10 mod [char] 0 + hold 0.1e f* loop
[char] . hold fdrop f>s #s ;
forth definitions internals
: #fs ( r -- ) fdup f0< if fnegate #f+s [char] - hold else #f+s then ;
: f. ( r -- ) <# #fs #> type space ;
: f.s ." <" fdepth n. ." > "
fdepth 0 max for aft fp@ r@ sfloats - sf@ f. then next ;
forth definitions

61
common/floats.h Normal file
View File

@ -0,0 +1,61 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#include <math.h>
#define FLOATING_POINT_LIST \
YV(internals, DOFLIT, *++fp = *(float *) ip++) \
X("FP@", FPAT, DUP; tos = (cell_t) fp) \
X("FP!", FPSTORE, fp = (float *) tos; DROP) \
X("SF@", FAT, *++fp = *(float *) tos; DROP) \
X("SF!", FSTORE, *(float *) tos = *fp--; DROP) \
X("FDUP", FDUP, fp[1] = *fp; ++fp) \
X("FNIP", FNIP, fp[-1] = *fp; --fp) \
X("FDROP", FDROP, --fp) \
X("FOVER", FOVER, fp[1] = fp[-1]; ++fp) \
X("FSWAP", FSWAP, float ft = fp[-1]; fp[-1] = *fp; *fp = ft) \
X("FNEGATE", FNEGATE, *fp = -*fp) \
X("F0<", FZLESS, DUP; tos = *fp-- < 0.0f ? -1 : 0) \
X("F0=", FZEQUAL, DUP; tos = *fp-- == 0.0f ? -1 : 0) \
X("F=", FEQUAL, DUP; tos = fp[-1] == fp[0] ? -1 : 0; fp -= 2) \
X("F<", FLESS, DUP; tos = fp[-1] < fp[0] ? -1 : 0; fp -= 2) \
X("F>", FGREATER, DUP; tos = fp[-1] > fp[0] ? -1 : 0; fp -= 2) \
X("F<>", FNEQUAL, DUP; tos = fp[-1] != fp[0] ? -1 : 0; fp -= 2) \
X("F<=", FLESSEQ, DUP; tos = fp[-1] <= fp[0] ? -1 : 0; fp -= 2) \
X("F>=", FGREATEREQ, DUP; tos = fp[-1] >= fp[0] ? -1 : 0; fp -= 2) \
X("F+", FPLUS, fp[-1] += *fp; --fp) \
X("F-", FMINUS, fp[-1] -= *fp; --fp) \
X("F*", FSTAR, fp[-1] *= *fp; --fp) \
X("F/", FSLASH, fp[-1] /= *fp; --fp) \
X("1/F", FINVERSE, *fp = 1.0 / *fp) \
X("S>F", STOF, *++fp = (float) tos; DROP) \
X("F>S", FTOS, DUP; tos = (cell_t) *fp--) \
XV(internals, "F>NUMBER?", FCONVERT, tos = fconvert((const char *) *sp, tos, fp); --sp) \
Y(SFLOAT, DUP; tos = sizeof(float)) \
Y(SFLOATS, tos *= sizeof(float)) \
X("SFLOAT+", SFLOATPLUS, DUP; tos += sizeof(float)) \
X("PI", PI_CONST, *++fp = 3.14159265359f) \
Y(FSIN, *fp = sin(*fp)) \
Y(FCOS, *fp = cos(*fp)) \
Y(FSINCOS, fp[1] = cos(*fp); *fp = sin(*fp); ++fp) \
Y(FATAN2, fp[-1] = atan2(fp[-1], *fp); --fp) \
X("F**", FSTARSTAR, fp[-1] = pow(fp[-1], *fp); --fp) \
Y(FLOOR, *fp = floor(*fp)) \
Y(FEXP, *fp = exp(*fp)) \
Y(FLN, *fp = log(*fp)) \
Y(FABS, *fp = fabs(*fp)) \
Y(FMIN, fp[-1] = fmin(fp[-1], *fp); --fp) \
Y(FMAX, fp[-1] = fmax(fp[-1], *fp); --fp) \
Y(FSQRT, *fp = sqrt(*fp))

653
common/forth_namespace_tests.fs Normal file
View File

@ -0,0 +1,653 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
also internals
: list-builtins ( voc )
>r 'builtins begin dup >link while
dup >params r@ = if dup see. cr then
3 cells +
repeat drop rdrop ;
: list-from ( xt ) begin dup nonvoc? while
dup >flags BUILTIN_FORK and if
dup cell+ @ list-builtins
then
dup see. cr
>link
repeat drop ;
e: check-locals
out: +to
out: to
out: exit
out: ;
out: {
out: (local)
;e
e: check-highlevel-floats
out: f.s
out: f.
out: #fs
out: set-precision
out: precision
out: fvariable
out: fconstant
out: fliteral
out: afliteral
out: sf,
;e
e: check-boot
out: quit
out: evaluate
out: prompt
out: refill
out: tib
out: accept
out: echo
out: z>s
out: s>z
out: r~
out: r|
out: r"
out: z"
out: ."
out: s"
out: n.
out: ?
out: .
out: u.
out: binary
out: decimal
out: octal
out: hex
out: str
out: #>
out: sign
out: #s
out: #
out: hold
out: <#
out: extract
out: pad
out: hld
out: cr
out: space
out: emit
out: bye
out: key?
out: key
out: type
out: is
out: defer
out: +to
out: to
out: value
out: throw
out: catch
out: handler
out: j
out: i
out: loop
out: +loop
out: leave
out: unloop
out: ?do
out: do
out: next
out: for
out: nest-depth
out: postpone
out: recurse
out: aft
out: repeat
out: while
out: else
out: if
out: then
out: ahead
out: until
out: again
out: begin
out: literal
out: [char]
out: char
out: [']
out: '
out: ]
out: [
out: used
out: remaining
out: fdepth
out: depth
out: fp0
out: rp0
out: sp0
out: #!
out: \
out: (
;e
e: check-extra-opcodes
out: nip
out: rdrop
out: */
out: *
out: /mod
out: /
out: mod
out: invert
out: negate
out: -
out: rot
out: -rot
out: <
out: >
out: <=
out: >=
out: =
out: <>
out: 0<>
out: bl
out: nl
out: 1+
out: 1-
out: 2*
out: 2/
out: 4*
out: 4/
out: +!
out: cell+
out: cells
out: cell/
out: 2drop
out: 2dup
out: 2@
out: 2!
out: cmove
out: cmove>
out: fill
out: erase
out: blank
out: min
out: max
out: abs
out: here
out: allot
out: aligned
out: align
out: ,
out: c,
out: >flags
out: >params
out: >size
out: >link&
out: >link
out: >name
out: >body
out: current
out: #tib
out: >in
out: state
out: base
out: context
out: latestxt
;e
e: check-core-opcodes
out: 0=
out: 0<
out: +
out: U/MOD
out: */MOD
out: LSHIFT
out: RSHIFT
out: AND
out: OR
out: XOR
out: DUP
out: SWAP
out: OVER
out: DROP
out: @
out: SL@
out: UL@
out: SW@
out: UW@
out: C@
out: !
out: L!
out: W!
out: C!
out: SP@
out: SP!
out: RP@
out: RP!
out: >R
out: R>
out: R@
out: EXECUTE
out: CELL
out: FIND
out: PARSE
out: CREATE
out: VARIABLE
out: CONSTANT
out: DOES>
out: IMMEDIATE
out: :
out: EXIT
out: ;
;e
e: check-float-opcodes
out: FP@
out: FP!
out: SF@
out: SF!
out: FDUP
out: FNIP
out: FDROP
out: FOVER
out: FSWAP
out: FNEGATE
out: F0<
out: F0=
out: F=
out: F<
out: F>
out: F<>
out: F<=
out: F>=
out: F+
out: F-
out: F*
out: F/
out: 1/F
out: S>F
out: F>S
out: SFLOAT
out: SFLOATS
out: SFLOAT+
out: PI
out: FSIN
out: FCOS
out: FSINCOS
out: FATAN2
out: F**
out: FLOOR
out: FEXP
out: FLN
out: FABS
out: FMIN
out: FMAX
out: FSQRT
;e
e: check-files
out: NON-BLOCK
out: FILE-SIZE
out: RESIZE-FILE
out: REPOSITION-FILE
out: FILE-POSITION
out: READ-FILE
out: WRITE-FILE
out: RENAME-FILE
out: DELETE-FILE
out: CREATE-FILE
out: OPEN-FILE
out: FLUSH-FILE
out: CLOSE-FILE
out: BIN
out: R/W
out: W/O
out: R/O
;e
e: check-files-reverse
out: R/O
out: W/O
out: R/W
out: BIN
out: CLOSE-FILE
out: FLUSH-FILE
out: OPEN-FILE
out: CREATE-FILE
out: DELETE-FILE
out: RENAME-FILE
out: WRITE-FILE
out: READ-FILE
out: FILE-POSITION
out: REPOSITION-FILE
out: RESIZE-FILE
out: FILE-SIZE
out: NON-BLOCK
;e
e: check-blocks
out: editor
out: list
out: copy
out: thru
out: load
out: flush
out: update
out: empty-buffers
out: buffer
out: block
out: save-buffers
out: default-use
out: use
out: open-blocks
out: block-id
out: scr
out: block-fid
;e
e: check-vocabulary
out: internals
out: sealed
out: previous
out: also
out: only
out: transfer{
out: }transfer
out: transfer
out: definitions
out: vocabulary
;e
e: check-[]conds
out: [IF]
out: [ELSE]
out: [THEN]
out: DEFINED?
;e
e: check-utils
out: words
out: vlist
out: order
out: see
out: .s
out: startswith?
out: str=
out: :noname
out: forget
out: dump
out: assert
;e
e: check-snapshots
out: reset
out: revive
out: startup:
out: remember
out: restore
out: save
out: dump-file
;e
e: check-ansi
out: set-title
out: page
out: at-xy
out: normal
out: bg
out: fg
out: ansi
;e
e: check-tasks
out: start-task
out: task
out: pause
out: tasks
;e
e: check-args
out: argv
out: argc
;e
e: check-highlevel
out: include
out: included
;e
e: check-allocation
out: resize
out: free
out: allocate
;e
e: check-phase1
out: structures
check-highlevel-floats
check-vocabulary
check-[]conds
check-boot
;e
e: check-opcodes
check-float-opcodes
check-extra-opcodes
check-core-opcodes
;e
e: check-desktop
out: grf
check-args
check-ansi
;e
e: check-phase2
check-blocks
out: streams
check-highlevel
check-snapshots
check-locals
check-utils
out: ms
check-tasks
;e
DEFINED? windows [IF]
e: test-windows-forth-namespace
internals voclist
out: internals
out: grf
out: ansi
out: editor
out: streams
out: tasks
out: windows
out: structures
out: internals
out: FORTH
;e
e: test-windows-forth-namespace
' forth list-from
out: FORTH
check-desktop
check-phase2
check-allocation
out: default-key?
out: default-key
out: default-type
check-files
out: ok
out: ms-ticks
out: ms
out: windows
check-phase1
out: GetProcAddress
out: LoadLibraryA
out: WindowProcShim
check-opcodes
out: forth-builtins
;e
[ELSE] DEFINED? posix [IF]
e: test-posix-forth-namespace
internals voclist
out: sockets
out: internals
out: grf
out: ansi
out: editor
out: streams
out: tasks
out: termios
out: posix
out: structures
out: internals
out: FORTH
;e
e: test-posix-forth-namespace
' forth list-from
out: FORTH
out:
out: web-interface
out: httpd
out: telnetd
out: sockets
out: x11
check-desktop
check-phase2
out: form
out: termios
check-allocation
out: ok
out: ms-ticks
out: ms
check-files
out: default-key
out: default-type
out: posix
check-phase1
out: DLSYM
check-opcodes
out: forth-builtins
;e
[ELSE]
e: test-esp32-forth-namespace
internals voclist
out: ansi
out: registers
out: oled
out: bluetooth
out: rtos
out: rmt
out: interrupts
out: sockets
out: Serial
out: ledc
out: SPIFFS
out: spi_flash
out: SD_MMC
out: SD
out: WiFi
out: Wire
out: ESP
out: editor
out: streams
out: tasks
out: structures
out: internals
out: FORTH
;e
e: check-esp32-platform
out: ok
out: LED
out: OUTPUT
out: INPUT
out: HIGH
out: LOW
out: page
out: tone
out: freq
out: duty
out: adc
out: pin
out: default-key?
out: default-key
out: default-type
;e
e: check-esp32-builtins
out: pinMode
out: digitalWrite
out: digitalRead
out: analogRead
out: pulseIn
out: MS-TICKS
out: TERMINATE
check-files-reverse
out: dacWrite
out: MDNS.begin
;e
e: test-esp32-forth-namespace
' forth list-from
out: FORTH
out: camera-server
out: camera
out: telnetd
out: bterm
out: timers
out: registers
out: webui
out: login
out:
out:
out: web-interface
out: httpd
check-esp32-platform
out: oled
out: bluetooth
out: rtos
out: rmt
out: interrupts
out: sockets
out: Serial
out: ledc
out: SPIFFS
out: spi_flash
out: SD_MMC
out: SD
out: WiFi
out: Wire
out: ESP
check-phase2
check-allocation
check-phase1
check-esp32-builtins
check-opcodes
out: forth-builtins
;e
[THEN] [THEN]

81
common/grf.fs Normal file
View File

@ -0,0 +1,81 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Generic Graphics Interface )
\ Startup:
\ window ( w h -- )
\ Drawing region:
\ pixel ( x y -- a ) (format [b g r x])
\ width ( -- n )
\ height ( -- n )
\ flip ( -- )
\ Getting events:
\ wait ( -- )
\ poll ( -- )
\ Event info:
\ mouse-x ( -- n )
\ mouse-y ( -- n )
\ last-key ( -- n )
\ last-char ( -- n )
\ pressed? ( k -- f )
\ event ( -- n )
\ Event constants:
\ IDLE RESIZED EXPOSED MOTION
\ PRESSED RELEASED TYPED FINISHED
\ Key/Button constants:
\ LEFT-BUTTON MIDDLE-BUTTON RIGHT-BUTTON
vocabulary grf grf definitions
vocabulary internals
0 constant IDLE
1 constant RESIZED
2 constant EXPOSED
3 constant MOTION
4 constant PRESSED
5 constant RELEASED
6 constant TYPED
7 constant FINISHED
255 constant LEFT-BUTTON
254 constant MIDDLE-BUTTON
253 constant RIGHT-BUTTON
0 value mouse-x
0 value mouse-y
0 value last-key
0 value last-char
0 value event
0 value width
0 value height
internals definitions
0 value backbuffer
256 constant key-count
create key-state key-count allot
key-state key-count erase
: key-state! ( f k ) key-count mod key-state + c! ;
grf definitions also internals
: pixel ( w h -- a ) width * + 4* backbuffer + ;
: pressed? ( k -- f ) key-state + c@ 0<> ;
( Rest of the core definitions per platform. )
only forth definitions

60
common/grf_test.fs Executable file
View File

@ -0,0 +1,60 @@
#! /usr/bin/env ueforth
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
grf
-1 -1 window
internals
: run
begin
wait
(
PRESSED event = if
." DOWN: " last-key . cr
then
RELEASED event = if
." UP: " last-key . cr
then
TYPED event = if
." CHAR: " last-char . cr
then
)
MOTION event = EXPOSED event = or if
0 to color 0 0 width height box
g{
vertical-flip
640 480 viewport
$ff0000 to color
0 0 640 480 box
$ff7700 to color
0 0 400 300 box
g{
mouse-x mouse-y screen>g translate
LEFT-BUTTON pressed? if $ccccff else $ffccff then to color
g{ -100 -100 translate 0 0 100 heart }g
g{ 100 -100 translate 0 0 100 heart }g
g{ -100 100 translate 0 0 100 heart }g
g{ 100 100 translate 0 0 100 heart }g
g{ -50 -50 100 100 box }g
}g
}g
flip
then
event FINISHED = until
bye
;
run

100
common/grf_utils.fs Normal file
View File

@ -0,0 +1,100 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Graphics Utilities )
\ Pen:
\ ( $rrggbb ) to color
\ Drawing:
\ box ( x y w h -- )
\ Transforms:
\ g{ ( -- ) Preserve transform
\ }g ( -- ) Restore transform
\ translate ( x y -- )
\ scale ( nx dx ny dy -- )
\ viewport ( w h -- )
\ vertical-flip ( -- ) Use math style viewport.
\ Conversions:
\ screen>g ( x y -- x' y' ) Transform screen to viewport
also internals
grf definitions
0 value color
internals definitions
( Scale to be divided by $10000 )
$10000 value sx $10000 value sy
( Translation )
0 value tx 0 value ty
: hline { x y w }
\ x y pixel w 1- for color over l! 4 + next drop ;
x y pixel w color fill32 ;
create gstack 1024 cells allot
gstack value gp
: >g ( n -- ) gp ! gp cell+ to gp ;
: g> ( -- n ) gp cell - to gp gp @ ;
: raw-box { left top w h }
left w + top h + { right bottom }
left right 2dup min to left max to right
top bottom 2dup min to top max to bottom
left 0 max to left
top 0 max to top
right width min to right
bottom height min to bottom
left right >= top bottom >= or if exit then
right left - to w
bottom top - to h
top h 1- for left over w hline 1+ next drop
;
grf definitions also internals
: box { left top w h }
left sx * tx + 16 rshift
top sy * ty + 16 rshift
w sx * 16 rshift
h sy * 16 rshift
raw-box
;
: screen>g ( x y -- x' y' ) 16 lshift ty - sy / swap
16 lshift tx - sx / swap ;
: g{ sx >g sy >g tx >g ty >g ;
: }g g> to ty g> to tx g> to sy g> to sx ;
: translate ( x y -- ) sy * +to ty sx * +to tx ;
: scale ( nx dx ny dy -- )
sy -rot */ to sy
sx -rot */ to sx ;
: viewport { w h }
width 2/ height 2/ translate
10000 width height */ 10000 w h */ < if
width w width h w */ 1 max h scale
else
height w h */ 1 max w height h scale
then
w 2/ negate h 2/ negate translate
;
: vertical-flip
0 height 2/ translate
1 1 -1 1 scale
0 height 2/ negate translate
;
only forth definitions

92
common/heart.fs Normal file
View File

@ -0,0 +1,92 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Graphics Heart )
\ Drawing:
\ heart ( x y h -- )
grf internals definitions
\ For t = 0 to 2pi
\ x = -16 to 16
\ y = -17 to 12
\ Goes around clockwise
\ x = 0 when t = pi
\ x = 0, y = 5 when t = 0
: heart-f ( f: t -- x y )
fdup fsin 3e f** 16e f* fswap
fdup fcos 13e f*
fover 2e f* fcos 5e f* f-
fover 3e f* fcos 2e f* f-
fswap 4e f* fcos f-
;
4000 constant heart-steps
1024 constant heart-size
create heart-start heart-size allot
create heart-end heart-size allot
heart-start heart-size 0 fill
heart-end heart-size 0 fill
: cmin! ( n a ) dup >r c@ min r> c! ;
: cmax! ( n a ) dup >r c@ max r> c! ;
: heart-initialize
heart-start heart-size 7 29 */ 128 fill
heart-end heart-size 7 29 */ 128 fill
heart-steps 0 do
i s>f heart-steps s>f f/ pi f* heart-f
fnegate 12e f+ 29.01e f/ heart-size s>f f* fswap 16e f* f>s f>s
2dup heart-start + cmin!
heart-end + cmax!
loop
heart-size 0 do
heart-end i + c@ heart-start i + c@ - heart-end i + c!
loop
;
512 29 32 */ constant heart-ratio
: raw-heart 0 { x y sx sy r }
heart-start c@ 0= if heart-initialize then
y sy 2/ - to y
sy 0< if
y sy + to y
sy abs to sy
then
sy 0 do
i heart-size sy */ to r
x heart-start r + c@ sx heart-ratio */ +
y i +
heart-end r + c@ sx heart-ratio */
1 raw-box
x heart-start r + c@
heart-end r + c@ + sx heart-ratio */ -
y i +
heart-end r + c@ sx heart-ratio */
1 raw-box
loop
;
grf definitions also internals
: heart 0 { x y s r }
x sx * tx + 16 rshift
y sy * ty + 16 rshift
s sx * 16 rshift
s sy * 16 rshift
raw-heart
;
only forth definitions

25
common/including.fs Normal file
View File

@ -0,0 +1,25 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Including Files )
: included ( a n -- )
r/o open-file dup if nip throw else drop then
dup file-size throw
dup allocate throw
swap 2dup >r >r
rot dup >r read-file throw drop
r> close-file throw
r> r> over >r evaluate
r> free throw ;
: include ( "name" -- ) bl parse included ;

44
common/interp.h Normal file
View File

@ -0,0 +1,44 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#define JMPW goto **(void **) w
#define NEXT w = *ip++; JMPW
#define ADDROF(x) (&& OP_ ## x)
static cell_t *forth_run(cell_t *init_rp) {
static const BUILTIN_WORD builtins[] = {
#define XV(flags, name, op, code) \
name, ((VOC_ ## flags >> 8) & 0xff) | BUILTIN_MARK, \
sizeof(name) - 1, (VOC_ ## flags & 0xff), && OP_ ## op,
PLATFORM_OPCODE_LIST
EXTRA_OPCODE_LIST
OPCODE_LIST
#undef XV
0, 0, 0,
};
if (!init_rp) {
g_sys.DOCREATE_OP = ADDROF(DOCREATE);
g_sys.builtins = builtins;
return 0;
}
register cell_t *ip, *rp, *sp, tos, w;
register float *fp;
rp = init_rp; UNPARK; NEXT;
#define XV(flags, name, op, code) OP_ ## op: { code; } NEXT;
PLATFORM_OPCODE_LIST
EXTRA_OPCODE_LIST
OPCODE_LIST
#undef XV
}

72
common/locals.fs Normal file
View File

@ -0,0 +1,72 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Local Variables )
( NOTE: These are not yet gforth compatible )
internals definitions
( Leave a region for locals definitions )
1024 constant locals-capacity 128 constant locals-gap
create locals-area locals-capacity allot
variable locals-here locals-area locals-here !
: <>locals locals-here @ here locals-here ! here - allot ;
: local@ ( n -- ) rp@ + @ ;
: local! ( n -- ) rp@ + ! ;
: local+! ( n -- ) rp@ + +! ;
variable scope-depth
variable local-op ' local@ local-op !
: scope-exit scope-depth @ for aft postpone rdrop then next ;
: scope-clear
scope-exit
scope-depth @ negate nest-depth +!
0 scope-depth ! 0 scope ! locals-area locals-here ! ;
: do-local ( n -- ) nest-depth @ + cells negate aliteral
local-op @ , ['] local@ local-op ! ;
: scope-create ( a n -- )
dup >r $place align ( name )
scope @ , r> 8 lshift 1 or , ( IMMEDIATE ) here scope ! ( link, flags&length )
['] scope-clear @ ( docol) ,
nest-depth @ negate aliteral postpone do-local ['] exit ,
1 scope-depth +! 1 nest-depth +!
;
: ?room locals-here @ locals-area - locals-capacity locals-gap - >
if scope-clear -1 throw then ;
: }? ( a n -- ) 1 <> if drop 0 exit then c@ [char] } = ;
: --? ( a n -- ) s" --" str= ;
: (to) ( xt -- ) ['] local! local-op ! execute ;
: (+to) ( xt -- ) ['] local+! local-op ! execute ;
also forth definitions
: (local) ( a n -- )
dup 0= if 2drop exit then
?room <>locals scope-create <>locals postpone >r ;
: { bl parse
dup 0= if scope-clear -1 throw then
2dup --? if 2drop [char] } parse 2drop exit then
2dup }? if 2drop exit then
recurse (local) ; immediate
( TODO: Hide the words overriden here. )
: ; scope-clear postpone ; ; immediate
: exit scope-exit postpone exit ; immediate
: to ( n -- ) ' dup >flags if (to) else ['] ! value-bind then ; immediate
: +to ( n -- ) ' dup >flags if (+to) else ['] +! value-bind then ; immediate
only forth definitions

85
common/locals_tests.fs Normal file
View File

@ -0,0 +1,85 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Testing Locals )
e: test-locals-one
: test { a } a a * ;
4 test 16 =assert
;e
e: test-locals-two
: test { a b } a a a b b ;
7 8 test .s
out: <5> 7 7 7 8 8
sp0 sp!
;e
e: test-alignment
30 allot
: color24 { r g b } r 16 lshift g 8 lshift b or or ;
1 2 3 color24 66051 =assert
;e
e: test-longname
: setPixelColor { pixelNum } pixelNum ;
1 setPixelColor 1 =assert
;e
e: test-dash
: test { a b c -- a a b b c c } a a b b c c ;
1 2 3 test * + * + * 23 =assert
;e
e: test-for-loop
: test { a b } 5 for a . b . next cr ;
1 2 test
out: 1 2 1 2 1 2 1 2 1 2 1 2
;e
e: test-do-loop
: test { a b } 5 0 do a . b . loop cr ;
1 2 test
out: 1 2 1 2 1 2 1 2 1 2
;e
e: test-do-+loop
: test { a b } 10 0 do i . a . b . 2 +loop cr ;
99 999 test
out: 0 99 999 2 99 999 4 99 999 6 99 999 8 99 999
;e
e: test-to
: test 0 { a b } 123 to b a . b . cr ;
3 test
out: 3 123
;e
e: test-to-loop
: test 0 { x } 5 0 do i i * to x x . loop cr ;
test
out: 0 1 4 9 16
;e
e: test-multi
: test { a b } 9 99 { c d } a . b . c . d . ;
1 2 test cr
out: 1 2 9 99
;e
e: test-multi-to
: test { a b } 9 99 { c d } 5 to c a . b . c . d . ;
1 2 test cr
out: 1 2 5 99
;e

152
common/opcodes.h Normal file
View File

@ -0,0 +1,152 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#include <inttypes.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
typedef intptr_t cell_t;
typedef uintptr_t ucell_t;
#define YV(flags, op, code) XV(flags, #op, op, code)
#define X(name, op, code) XV(forth, name, op, code)
#define Y(op, code) XV(forth, #op, op, code)
#define NIP (--sp)
#define NIPn(n) (sp -= (n))
#define DROP (tos = *sp--)
#define DROPn(n) (NIPn(n-1), DROP)
#define DUP (*++sp = tos)
#define PUSH DUP; tos = (cell_t)
#define COMMA(n) *g_sys.heap++ = (n)
#define DOES(ip) **g_sys.current = (cell_t) ADDROF(DODOES); (*g_sys.current)[1] = (cell_t) ip
#define PARK DUP; *++rp = (cell_t) fp; *++rp = (cell_t) sp; *++rp = (cell_t) ip
#define UNPARK ip = (cell_t *) *rp--; sp = (cell_t *) *rp--; fp = (float *) *rp--; DROP
#define TOFLAGS(xt) ((uint8_t *) (((cell_t *) (xt)) - 1))
#define TONAMELEN(xt) (TOFLAGS(xt) + 1)
#define TOPARAMS(xt) ((uint16_t *) (TOFLAGS(xt) + 2))
#define TOSIZE(xt) (CELL_ALIGNED(*TONAMELEN(xt)) + sizeof(cell_t) * (3 + *TOPARAMS(xt)))
#define TOLINK(xt) (((cell_t *) (xt)) - 2)
#define TONAME(xt) ((*TOFLAGS(xt) & BUILTIN_MARK) ? (*(char **) TOLINK(xt)) \
: (((char *) TOLINK(xt)) - CELL_ALIGNED(*TONAMELEN(xt))))
#define TOBODY(xt) (((cell_t *) xt) + ((void *) *((cell_t *) xt) == ADDROF(DOCREATE) || \
(void *) *((cell_t *) xt) == ADDROF(DODOES) ? 2 : 1))
#define DOIMMEDIATE() *TOFLAGS(*g_sys.current) |= IMMEDIATE
#define UNSMUDGE() *TOFLAGS(*g_sys.current) &= ~SMUDGE; finish()
#ifndef SSMOD_FUNC
# if __SIZEOF_POINTER__ == 8
typedef __int128_t dcell_t;
# elif __SIZEOF_POINTER__ == 4 || defined(_M_IX86)
typedef int64_t dcell_t;
# else
# error "unsupported cell size"
# endif
# define SSMOD_FUNC dcell_t d = (dcell_t) *sp * (dcell_t) sp[-1]; \
--sp; cell_t a = (cell_t) (d < 0 ? ~(~d / tos) : d / tos); \
*sp = (cell_t) (d - ((dcell_t) a) * tos); tos = a
#endif
typedef struct {
const char *name;
union {
struct {
uint8_t flags, name_length;
uint16_t vocabulary;
};
cell_t multi;
};
const void *code;
} BUILTIN_WORD;
#define OPCODE_LIST \
X("0=", ZEQUAL, tos = !tos ? -1 : 0) \
X("0<", ZLESS, tos = (tos|0) < 0 ? -1 : 0) \
X("+", PLUS, tos += *sp--) \
X("U/MOD", USMOD, w = *sp; *sp = (ucell_t) w % (ucell_t) tos; \
tos = (ucell_t) w / (ucell_t) tos) \
X("*/MOD", SSMOD, SSMOD_FUNC) \
Y(LSHIFT, tos = (*sp-- << tos)) \
Y(RSHIFT, tos = (*sp-- >> tos)) \
Y(AND, tos &= *sp--) \
Y(OR, tos |= *sp--) \
Y(XOR, tos ^= *sp--) \
XV(forth, "DUP", ALTDUP, DUP) \
Y(SWAP, w = tos; tos = *sp; *sp = w) \
Y(OVER, DUP; tos = sp[-1]) \
XV(forth, "DROP", ALTDROP, DROP) \
X("@", AT, tos = *(cell_t *) tos) \
X("SL@", SLAT, tos = *(int32_t *) tos) \
X("UL@", ULAT, tos = *(uint32_t *) tos) \
X("SW@", SWAT, tos = *(int16_t *) tos) \
X("UW@", UWAT, tos = *(uint16_t *) tos) \
X("C@", CAT, tos = *(uint8_t *) tos) \
X("!", STORE, *(cell_t *) tos = *sp--; DROP) \
X("L!", LSTORE, *(int32_t *) tos = *sp--; DROP) \
X("W!", WSTORE, *(int16_t *) tos = *sp--; DROP) \
X("C!", CSTORE, *(uint8_t *) tos = *sp--; DROP) \
X("SP@", SPAT, DUP; tos = (cell_t) sp) \
X("SP!", SPSTORE, sp = (cell_t *) tos; DROP) \
X("RP@", RPAT, DUP; tos = (cell_t) rp) \
X("RP!", RPSTORE, rp = (cell_t *) tos; DROP) \
X(">R", TOR, *++rp = tos; DROP) \
X("R>", FROMR, DUP; tos = *rp; --rp) \
X("R@", RAT, DUP; tos = *rp) \
Y(EXECUTE, w = tos; DROP; JMPW) \
YV(internals, BRANCH, ip = (cell_t *) *ip) \
YV(internals, 0BRANCH, if (!tos) ip = (cell_t *) *ip; else ++ip; DROP) \
YV(internals, DONEXT, *rp = *rp - 1; if (~*rp) ip = (cell_t *) *ip; else (--rp, ++ip)) \
YV(internals, DOLIT, DUP; tos = *ip++) \
YV(internals, DOSET, *((cell_t *) *ip++) = tos; DROP) \
YV(internals, DOCOL, ++rp; *rp = (cell_t) ip; ip = (cell_t *) (w + sizeof(cell_t))) \
YV(internals, DOCON, DUP; tos = *(cell_t *) (w + sizeof(cell_t))) \
YV(internals, DOVAR, DUP; tos = w + sizeof(cell_t)) \
YV(internals, DOCREATE, DUP; tos = w + sizeof(cell_t) * 2) \
YV(internals, DODOES, DUP; tos = w + sizeof(cell_t) * 2; \
++rp; *rp = (cell_t) ip; \
ip = (cell_t *) *(cell_t *) (w + sizeof(cell_t))) \
YV(internals, ALITERAL, COMMA(g_sys.DOLIT_XT); COMMA(tos); DROP) \
Y(CELL, DUP; tos = sizeof(cell_t)) \
XV(internals, "LONG-SIZE", LONG_SIZE, DUP; tos = sizeof(long)) \
Y(FIND, tos = find((const char *) *sp, tos); --sp) \
Y(PARSE, DUP; tos = parse(tos, sp)) \
XV(internals, "S>NUMBER?", \
CONVERT, tos = convert((const char *) *sp, tos, g_sys.base, sp); \
if (!tos) --sp) \
Y(CREATE, DUP; DUP; tos = parse(32, sp); \
create((const char *) *sp, tos, 0, ADDROF(DOCREATE)); \
COMMA(0); DROPn(2)) \
Y(VARIABLE, DUP; DUP; tos = parse(32, sp); \
create((const char *) *sp, tos, 0, ADDROF(DOVAR)); \
COMMA(0); DROPn(2)) \
Y(CONSTANT, DUP; DUP; tos = parse(32, sp); \
create((const char *) *sp, tos, 0, ADDROF(DOCON)); \
DROPn(2); COMMA(tos); DROP) \
X("DOES>", DOES, DOES(ip); ip = (cell_t *) *rp; --rp) \
Y(IMMEDIATE, DOIMMEDIATE()) \
XV(internals, "'SYS", SYS, DUP; tos = (cell_t) &g_sys) \
YV(internals, YIELD, PARK; return rp) \
X(":", COLON, DUP; DUP; tos = parse(32, sp); \
create((const char *) *sp, tos, SMUDGE, ADDROF(DOCOL)); \
g_sys.state = -1; --sp; DROP) \
YV(internals, EVALUATE1, DUP; float *tfp = fp; \
sp = evaluate1(sp, &tfp); \
fp = tfp; w = *sp--; DROP; if (w) JMPW) \
Y(EXIT, ip = (cell_t *) *rp--) \
XV(internals, "'builtins", TBUILTINS, DUP; tos = (cell_t) &g_sys.builtins->code) \
XV(forth_immediate, ";", SEMICOLON, COMMA(g_sys.DOEXIT_XT); UNSMUDGE(); g_sys.state = 0)

62
common/source_to_string.js Executable file
View File

@ -0,0 +1,62 @@
#! /usr/bin/env nodejs
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
var fs = require('fs');
function DropCopyright(source) {
var lines = source.split('\n');
var cleaned = [];
for (var i = 0; i < lines.length; ++i) {
if (lines[i].search('Copyright') >= 0) {
while (lines[i] != '') {
++i;
}
} else {
cleaned.push(lines[i]);
}
}
return cleaned.join('\n');
}
var is_windows = false;
var args = process.argv.slice(2);
if (args.length > 0 && args[0] == '-win') {
is_windows = true;
args.shift();
}
var name = args.shift();
var version = args.shift();
var revision = args.shift();
var source = '';
while (args.length > 0) {
source += DropCopyright(fs.readFileSync(args.shift()).toString());
}
source = source.replace('{{VERSION}}', version);
source = source.replace('{{REVISION}}', revision);
if (is_windows) {
source = source.replace(/\\/g, '\\\\');
source = source.replace(/["]/g, '\\"');
source = '"' + source.split('\n').join('\\n"\n"') + '\\n"';
source = source.replace(/["] ["]/g, '');
source = source.replace(/["] [(] ([^)]*)[)] ["]/g, '// $1');
source = 'const char ' + name + '[] =\n' + source + ';\n';
} else {
source = 'const char ' + name + '[] = R"""(\n' + source + ')""";\n';
}
process.stdout.write(source);

41
common/streams.fs Normal file
View File

@ -0,0 +1,41 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Byte Stream / Ring Buffer )
vocabulary streams streams definitions
: stream ( n "name" ) create 1+ dup , 0 , 0 , allot align ;
: >write ( st -- wr ) cell+ ; : >read ( st -- rd ) 2 cells + ;
: >offset ( n st -- a ) 3 cells + + ;
: stream# ( sz -- n ) >r r@ >write @ r@ >read @ - r> @ mod ;
: full? ( st -- f ) dup stream# swap @ 1- = ;
: empty? ( st -- f ) stream# 0= ;
: wait-write ( st -- ) begin dup full? while pause repeat drop ;
: wait-read ( st -- ) begin dup empty? while pause repeat drop ;
: ch>stream ( ch st -- )
dup wait-write
>r r@ >write @ r@ >offset c!
r@ >write @ 1+ r@ @ mod r> >write ! ;
: stream>ch ( st -- ch )
dup wait-read
>r r@ >read @ r@ >offset c@
r@ >read @ 1+ r@ @ mod r> >read ! ;
: >stream ( a n st -- )
swap for aft over c@ over ch>stream swap 1+ swap then next 2drop ;
: stream> ( a n st -- )
begin over 1 > over empty? 0= and while
dup stream>ch >r rot dup r> swap c! 1+ rot 1- rot repeat 2drop 0 swap c! ;
forth definitions

41
common/structures.fs Normal file
View File

@ -0,0 +1,41 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Vocabulary for building C-style structures )
vocabulary structures structures definitions
variable last-align
: typer ( align sz "name" ) create , ,
does> dup cell+ @ last-align ! @ ;
1 1 typer i8
2 2 typer i16
4 4 typer i32
cell 8 typer i64
cell cell typer ptr
long-size long-size typer long
variable last-struct
: struct ( "name" ) 1 0 typer latestxt >body last-struct ! ;
: align-by ( a n -- a ) 1- dup >r + r> invert and ;
: struct-align ( n -- )
dup last-struct @ cell+ @ max last-struct @ cell+ !
last-struct @ @ swap align-by last-struct @ ! ;
: field ( n "name" )
last-align @ struct-align
create last-struct @ @ , last-struct @ +!
does> @ + ;
forth definitions

48
common/structures_tests.fs Normal file
View File

@ -0,0 +1,48 @@
\ Copyright 2022 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
e: test-structure
also structures
struct gappy
ptr field ->first
i8 field ->foo
i16 field ->bar
i32 field ->baz
1000 ->first 1000 =assert
1000 ->foo 1000 cell+ =assert
1000 ->bar 1002 cell+ =assert
1000 ->baz 1004 cell+ =assert
i8 1 =assert
i16 2 =assert
i32 4 =assert
i64 8 =assert
ptr cell =assert
;e
e: test-nested-structure
also structures
struct rect
i32 field ->left
i32 field ->top
i32 field ->right
i32 field ->bottom
struct gappy
i16 field ->foo
rect field ->bar
1000 ->foo 1000 =assert
1000 ->bar ->left 1004 =assert
1000 ->bar ->top 1008 =assert
1000 ->bar ->right 1012 =assert
1000 ->bar ->bottom 1016 =assert
;e

25
common/tasking_tester.fs Normal file
View File

@ -0,0 +1,25 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Trying some things with tasks )
: printer1 42 emit 1000 ms ;
: printer2 43 emit 500 ms ;
: runner begin pause again ;
' printer1 1000 1000 task print1
' printer2 1000 1000 task print2
print1 start-task
print2 start-task
runner

54
common/tasks.fs Normal file
View File

@ -0,0 +1,54 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Cooperative Tasks )
vocabulary tasks tasks definitions
variable task-list
forth definitions tasks also internals
: pause
rp@ sp@ task-list @ cell+ !
task-list @ @ task-list !
task-list @ cell+ @ sp! rp!
;
: task ( xt dsz rsz "name" )
create here >r 0 , 0 , ( link, sp )
swap here cell+ r@ cell+ ! cells allot
here r@ cell+ @ ! cells allot
dup 0= if drop else
here r@ cell+ @ @ ! ( set rp to point here )
, postpone pause ['] branch , here 3 cells - ,
then rdrop ;
: start-task ( t -- )
task-list @ if
task-list @ @ over !
task-list @ !
else
dup task-list !
dup !
then
;
DEFINED? ms-ticks [IF]
: ms ( n -- ) ms-ticks >r begin pause ms-ticks r@ - over >= until rdrop drop ;
[THEN]
tasks definitions
0 0 0 task main-task main-task start-task
forth definitions

121
common/testing.fs Normal file
View File

@ -0,0 +1,121 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
also ansi also internals
DEFINED? windows [IF]
also windows
: sysexit ( n -- ) ExitProcess ;
[ELSE]
DEFINED? posix [IF]
also posix
[ELSE]
: sysexit ( n -- ) terminate ;
[THEN]
[THEN]
( Support for eval tests )
40000 constant expect-limit
create expect-buffer expect-limit allot
create result-buffer expect-limit allot
variable expect-used variable result-used
: till;e ( -- n )
begin >in @ bl parse dup 0= >r s" ;e" str= r> or if exit then drop again ;
: e: ( "name" -- ) create >in @
till;e over - swap tib + swap dup , $place
does> dup cell+ swap @ evaluate ;
: expect-emit ( ch -- ) expect-used @ expect-limit < assert
expect-buffer expect-used @ + c!
1 expect-used +! ;
: result-emit ( ch -- ) result-used @ expect-limit < assert
result-buffer result-used @ + c!
1 result-used +! ;
: expect-type ( a n -- ) for aft dup c@ expect-emit 1+ then next drop ;
: result-type ( a n -- ) for aft dup c@ result-emit 1+ then next drop ;
: expected ( -- a n ) expect-buffer expect-used @ ;
: resulted ( -- a n ) result-buffer result-used @ ;
: out:cr nl expect-emit ;
: out:\ ( "line" -- ) nl parse expect-type ;
: out: ( "line" -- ) out:\ out:cr ;
variable confirm-old-type
: confirm{ ['] type >body @ confirm-old-type ! ['] result-type is type ;
: }confirm confirm-old-type @ is type ;
: expect-reset 0 expect-used ! 0 result-used ! ;
: diverged ( a n a n -- a n )
begin
dup 0= if 2drop exit then
>r dup c@ >r rot dup c@ >r -rot r> r> <> r> swap if 2drop exit then
>r >r dup 0= if rdrop rdrop exit then r> r>
>r >r >r 1+ r> 1- r> 1+ r> 1-
again
;
: stars ( n -- ) 1- for 42 emit next ;
: expect-finish expected resulted str= if exit then }confirm
cr ." Expected:" cr expected resulted diverged type 30 stars cr
." Resulted:" cr resulted expected diverged type 30 stars cr 1 throw ;
( Better error asserts )
: =assert ( actual expected -- )
2dup <> if }confirm ." FAILURE! EXPECTED: " .
." ACTUAL: " . space 0 assert then 2drop ;
: <assert ( actual expected -- )
2dup >= if }confirm ." MUST BE LESS THAN: " .
." ACTUAL: " . space 0 assert then 2drop ;
: >assert ( actual expected -- )
2dup <= if }confirm ." MUST BE GREATER THAN: " .
." ACTUAL: " . space 0 assert then 2drop ;
( Input testing )
create in-buffer 1000 allot
variable in-head variable in-tail
: >in ( c -- ) in-buffer in-head @ + c! 1 in-head +! ;
: in> ( -- c ) in-tail @ in-head @ <assert
in-buffer in-tail @ + c@ 1 in-tail +!
in-head @ in-tail @ = if 0 in-head ! 0 in-tail ! then ;
: s>in ( a n -- ) for aft dup c@ >in 1+ then next drop ;
: in: ( "line" -- ) nl parse s>in nl >in ;
' in> is key
( Testing Framework )
( run-tests runs all words starting with "test-", use assert to assert things. )
variable tests-found variable tests-run variable tests-passed
: test? ( xt -- f ) >name s" test-" startswith? ;
: for-tests ( xt -- )
context @ @ begin dup while dup test? if 2dup >r >r swap execute r> r> then >link repeat 2drop ;
: reset-test-counters 0 tests-found ! 0 tests-run ! 0 tests-passed ! ;
: count-test ( xt -- ) drop 1 tests-found +! ;
: check-fresh depth if }confirm ." DEPTH LEAK! " depth . 1 throw then
fdepth if }confirm ." FDEPTH LEAK! " fdepth . 1 throw then ;
: wrap-test ( xt -- ) expect-reset >r check-fresh r> execute check-fresh expect-finish ;
: red 1 fg ; : green 2 fg ; : hr 40 for [char] - emit next cr ;
: replace-line 13 emit clear-to-eol ;
: label-test ( xt -- ) replace-line >name type ;
: run-test ( xt -- ) dup label-test only forth confirm{ ['] wrap-test catch }confirm
if drop ( cause xt restored on throw ) red ." FAILED" normal cr
else green ." OK" normal 1 tests-passed +! then 1 tests-run +! ;
: show-test-results
replace-line hr
." PASSED: " green tests-passed @ . normal
." RUN: " tests-run @ .
." FOUND: " tests-found @ . cr
tests-passed @ tests-found @ = if
green ." ALL TESTS PASSED" normal cr
else
." FAILED: " red tests-run @ tests-passed @ - . normal cr
then hr ;
: run-tests
reset-test-counters ['] count-test for-tests
['] run-test for-tests show-test-results
tests-passed @ tests-found @ <> sysexit ;
only forth

128
common/utils.fs Normal file
View File

@ -0,0 +1,128 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Words built after boot )
( For tests and asserts )
: assert ( f -- ) 0= throw ;
( Examine Memory )
: dump ( a n -- )
cr 0 do i 16 mod 0= if cr then dup i + c@ . loop drop cr ;
( Remove from Dictionary )
: forget ( "name" ) ' dup >link current @ ! >name drop here - allot ;
internals definitions
2 constant SMUDGE
4 constant BUILTIN_FORK
16 constant NONAMED
: mem= ( a a n -- f)
for aft 2dup c@ swap c@ <> if 2drop rdrop 0 exit then 1+ swap 1+ then next 2drop -1 ;
forth definitions also internals
: :noname ( -- xt ) 0 , current @ @ , NONAMED SMUDGE or ,
here dup current @ ! ['] mem= @ , postpone ] ;
: str= ( a n a n -- f) >r swap r@ <> if rdrop 2drop 0 exit then r> mem= ;
: startswith? ( a n a n -- f ) >r swap r@ < if rdrop 2drop 0 exit then r> mem= ;
: .s ." <" depth n. ." > " raw.s cr ;
only forth definitions
( Definitions building to SEE and ORDER )
internals definitions
: see. ( xt -- ) >name type space ;
: see-one ( xt -- xt+1 )
dup cell+ swap @
dup ['] DOLIT = if drop dup @ . cell+ exit then
dup ['] DOSET = if drop ." TO " dup @ cell - see. cell+ exit then
dup ['] DOFLIT = if drop dup sf@ <# [char] e hold #fs #> type space cell+ exit then
dup ['] $@ = if drop ['] s" see.
dup @ dup >r >r dup cell+ r> type cell+ r> 1+ aligned +
[char] " emit space exit then
dup ['] BRANCH =
over ['] 0BRANCH = or
over ['] DONEXT = or
if see. cell+ exit then
see. ;
: see-loop dup >body swap >params 1- cells over +
begin 2dup < while swap see-one swap repeat 2drop ;
: see-xt ( xt -- )
dup @ ['] see-loop @ = if
['] : see. dup see. space see-loop ['] ; see. cr exit
then
dup >flags BUILTIN_FORK and if ." Built-in fork: " see. exit then
dup @ ['] input-buffer @ = if ." CREATE/VARIABLE: " see. cr exit then
dup @ ['] SMUDGE @ = if ." DOES>/CONSTANT: " see. cr exit then
dup >params 0= if ." Built-in: " see. cr exit then
." Unsupported: " see. cr ;
: nonvoc? ( xt -- f )
dup 0= if exit then dup >name nip swap >flags NONAMED BUILTIN_FORK or and or ;
: see-vocabulary ( voc )
@ begin dup nonvoc? while dup see-xt >link repeat drop cr ;
: >vocnext ( xt -- xt ) >body 2 cells + @ ;
: see-all
last-vocabulary @ begin dup while
." VOCABULARY " dup see. cr ." ------------------------" cr
dup >body see-vocabulary
>vocnext
repeat drop cr ;
: voclist last-vocabulary @ begin dup while dup see. cr >vocnext repeat drop ;
: voc. ( voc -- ) 2 cells - see. ;
: vocs. ( voc -- ) dup voc. @ begin dup while
dup nonvoc? 0= if ." >> " dup 2 cells - voc. then
>link
repeat drop cr ;
( Words to measure size of things )
: size-vocabulary ( voc )
@ begin dup nonvoc? while
dup >params . dup >size . dup . dup see. cr >link
repeat drop ;
: size-all
last-vocabulary @ begin dup while
0 . 0 . 0 . dup see. cr
dup >body size-vocabulary
>vocnext
repeat drop cr ;
forth definitions also internals
: see ' see-xt ;
: order context begin dup @ while dup @ vocs. cell+ repeat drop ;
only forth definitions
( List words in Dictionary / Vocabulary )
internals definitions
70 value line-width
0 value line-pos
: onlines ( xt -- xt )
line-pos line-width > if cr 0 to line-pos then
dup >name nip 1+ line-pos + to line-pos ;
: vins. ( voc -- )
>r 'builtins begin dup >link while
dup >params r@ = if dup onlines see. then
3 cells +
repeat drop rdrop ;
: ins. ( n xt -- n ) cell+ @ vins. ;
: ?ins. ( xt -- xt ) dup >flags BUILTIN_FORK and if dup ins. then ;
forth definitions also internals
: vlist 0 to line-pos context @ @
begin dup nonvoc? while ?ins. dup onlines see. >link repeat drop cr ;
: words 0 to line-pos context @ @
begin dup while ?ins. dup onlines see. >link repeat drop cr ;
only forth definitions
( Extra Task Utils )
tasks definitions also internals
: .tasks task-list @ begin dup 2 cells - see. @ dup task-list @ = until drop ;
only forth definitions

138
common/utils_tests.fs Normal file
View File

@ -0,0 +1,138 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Tests of utils.fs )
e: test-.s0
.s
out: <0>
;e
e: test-.s
1 2 3 .s
out: <3> 1 2 3
128 .s
out: <4> 1 2 3 128
2drop 2drop
.s
out: <0>
;e
e: test-forget
context @ @
current @
here
: foo 123 ;
: bar foo foo ;
: baz bar bar * * ;
forget foo
here =assert
current @ =assert
context @ @ =assert
;e
e: test-see-number
: test 123 456 ;
see test
out: : test 123 456 ;
;e
e: test-see-string
: test s" hello there" ;
see test
out: : test s" hello there" ;
;e
e: test-see-branch
: test begin again ;
see test
out: : test BRANCH ;
;e
e: test-see-0branch
: test begin until ;
see test
out: : test 0BRANCH ;
;e
e: test-see-fornext
: test for next ;
see test
out: : test >R DONEXT ;
;e
e: test-see-string-strides
: test0 1 if ." " then ;
: test1 1 if ." >" then ;
: test2 1 if ." ->" then ;
: test3 1 if ." -->" then ;
: test4 1 if ." --->" then ;
: test5 1 if ." ---->" then ;
: test6 1 if ." ----->" then ;
: test7 1 if ." ------>" then ;
: test8 1 if ." ------->" then ;
see test0
out: : test0 1 0BRANCH s" " type ;
see test1
out: : test1 1 0BRANCH s" >" type ;
see test2
out: : test2 1 0BRANCH s" ->" type ;
see test3
out: : test3 1 0BRANCH s" -->" type ;
see test4
out: : test4 1 0BRANCH s" --->" type ;
see test5
out: : test5 1 0BRANCH s" ---->" type ;
see test6
out: : test6 1 0BRANCH s" ----->" type ;
see test7
out: : test7 1 0BRANCH s" ------>" type ;
see test8
out: : test8 1 0BRANCH s" ------->" type ;
;e
e: test-noname
:noname dup * ;
2 over execute
swap execute
. cr
out: 16
;e
e: test-see-variable
variable foo
: bar foo @ . ;
see bar
out: : bar foo @ . ;
;e
e: test-see-create
create foo
: bar foo @ . ;
see bar
out: : bar foo @ . ;
;e
e: test-see-value
0 value foo
: bar foo . ;
see bar
out: : bar foo . ;
;e
e: test-see-to
0 value foo
: bar 123 to foo ;
see bar
out: : bar 123 TO foo ;
;e

76
common/vocabulary.fs Normal file
View File

@ -0,0 +1,76 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Implement Vocabularies )
( normal: link, flags&len, code )
( vocab: link, flags&len, code | link , len=0, voclink )
variable last-vocabulary
: vocabulary ( "name" )
create current @ 2 cells + , 0 , last-vocabulary @ ,
current @ @ last-vocabulary !
does> context ! ;
: definitions context @ current ! ;
vocabulary FORTH
' forth >body @ >link ' forth >body !
forth definitions
( Make it easy to transfer words between vocabularies )
: xt-find& ( xt -- xt& ) context @ begin 2dup @ <> while @ >link& repeat nip ;
: xt-hide ( xt -- ) xt-find& dup @ >link swap ! ;
8 constant BUILTIN_MARK
: xt-transfer ( xt -- ) dup >flags BUILTIN_MARK and if drop exit then
dup xt-hide current @ @ over >link& ! current @ ! ;
: transfer ( "name" ) ' xt-transfer ;
: }transfer ;
: transfer{ begin ' dup ['] }transfer = if drop exit then xt-transfer again ;
( Watered down versions of these )
: only forth 0 context cell+ ! ;
: voc-stack-end ( -- a ) context begin dup @ while cell+ repeat ;
: also context context cell+ voc-stack-end over - 2 cells + cmove> ;
: previous
voc-stack-end context cell+ = throw
context cell+ context voc-stack-end over - cell+ cmove ;
: sealed 0 last-vocabulary @ >body ! ;
( Hide some words in an internals vocabulary )
vocabulary internals internals definitions
( Vocabulary chain for current scope, place at the -1 position )
variable scope scope context cell - !
transfer{
xt-find& xt-hide xt-transfer
voc-stack-end last-vocabulary notfound
immediate? input-buffer ?echo ?arrow. arrow
evaluate-buffer aliteral value-bind
leaving( )leaving leaving leaving,
(do) (?do) (+loop)
parse-quote digit $@ raw.s
tib-setup input-limit
[SKIP] [SKIP]' raw-ok boot-prompt free.
$place zplace BUILTIN_MARK
}transfer
forth definitions
( Make DOES> switch to compile mode when interpreted )
(
forth definitions internals
' does>
: does> state @ if postpone does> exit then
['] constant @ current @ @ dup >r !
here r> cell+ ! postpone ] ; immediate
xt-hide
forth definitions
)

171
common/vocabulary_tests.fs Normal file
View File

@ -0,0 +1,171 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
e: test-vocabularies
vocabulary foo
vocabulary bar
foo definitions : test ." AAAA" cr ;
bar definitions : test ." BBBB" cr ;
forth definitions
foo test
bar test
foo test
forth definitions
out: AAAA
out: BBBB
out: AAAA
;e
e: test-vlist
vocabulary foo
foo definitions
: pig ; : cow ; : sheep ;
forth definitions
foo vlist
forth definitions
out: sheep cow pig
;e
e: test-vlist-empty
vocabulary foo
foo vlist
forth definitions
out:
;e
e: test-order
vocabulary foo
vocabulary bar
vocabulary baz
also foo also bar also baz
order
out: baz >> FORTH
out: bar >> FORTH
out: foo >> FORTH
out: FORTH
only forth definitions
;e
e: test-order-previous
vocabulary foo
vocabulary bar
vocabulary baz
also foo also bar also baz
order
out: baz >> FORTH
out: bar >> FORTH
out: foo >> FORTH
out: FORTH
previous order
out: bar >> FORTH
out: foo >> FORTH
out: FORTH
previous order
out: foo >> FORTH
out: FORTH
previous order
out: FORTH
;e
e: test-previous-throw
only forth definitions
' previous catch 0<> assert
;e
e: test-vocab-define-order
vocabulary foo
foo definitions
: a ." AAAAAA" cr ;
forth definitions
: a ." BAD" cr ;
foo a
out: AAAAAA
only forth definitions
;e
e: test-vocabulary-chaining
vocabulary foo
foo definitions
vocabulary bar
bar definitions
: a ." aaaa" cr ;
foo definitions
: b ." bbbb" cr ;
forth definitions
: a ." BAD" cr ;
: b ." BAD" cr ;
foo a b
out: BAD
out: bbbb
bar a b
out: aaaa
out: bbbb
only forth definitions
;e
e: test-sealed
: aaa ." good" cr ;
vocabulary foo
foo definitions
: aaa ." bad" cr ;
vocabulary bar sealed
also bar definitions
: bbb ." b" cr ;
only forth definitions
also foo bar
aaa
bbb
out: good
out: b
only forth definitions
;e
e: test-nested
vocabulary foo
foo definitions
: hi ;
: there ;
vocabulary bar
bar definitions
: a ;
: b ;
vlist
out: b a
only forth definitions
;e
e: test-fixed-does>-normal
: adder create , does> @ + ;
3 adder foo
4 foo 7 =assert
4 ' foo execute 7 =assert
;e
also internals
variable see-tally
: tally-type ( a n -- ) nip see-tally +! ;
: test-see-all
0 see-tally !
['] tally-type is type
see-all
['] default-type is type
see-tally @ 25000 >assert
;
(
e: test-fixed-does>-interp
create hi 123 , does> @ + ;
7 hi 130 =assert
;e
)