125 lines
4.4 KiB
Forth
125 lines
4.4 KiB
Forth
\ 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-from ( voc -- ) begin dup while dup see. cr >vocnext repeat drop ;
|
|
: voclist last-vocabulary @ voclist-from ;
|
|
: 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
|