Re-root site.

2022-02-27 20:59:19 -08:00
parent a26786d7ef
commit fb47179999
131 changed files with 27 additions and 39 deletions
--- a/common/utils.fs
+++ b/common/utils.fs
@ -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