diff --git a/share/examples/bootforth/boot.4th b/share/examples/bootforth/boot.4th index 8f26e0d0a38d..3f75424e46c5 100644 --- a/share/examples/bootforth/boot.4th +++ b/share/examples/bootforth/boot.4th @@ -1,22 +1,21 @@ \ Example of the file which is automatically loaded by /boot/loader \ on startup. -\ $FreeBSD$ \ Load the screen manipulation words cr .( Loading Forth extensions:) cr .( - screen.4th...) s" /boot/screen.4th" O_RDONLY fopen dup fload fclose \ Load frame support cr .( - frames.4th...) s" /boot/frames.4th" O_RDONLY fopen dup fload fclose \ Load our little menu cr .( - menu.4th...) s" /boot/menu.4th" O_RDONLY fopen dup fload fclose \ Show it cr main_menu diff --git a/share/examples/bootforth/frames.4th b/share/examples/bootforth/frames.4th index 4f1f9b812a03..0adcf9ef648b 100644 --- a/share/examples/bootforth/frames.4th +++ b/share/examples/bootforth/frames.4th @@ -1,89 +1,88 @@ \ Words implementing frame drawing \ XXX Filled boxes are left as an exercise for the reader... ;-/ -\ $FreeBSD$ marker task-frames.4th variable h_el variable v_el variable lt_el variable lb_el variable rt_el variable rb_el variable fill \ Single frames 196 constant sh_el 179 constant sv_el 218 constant slt_el 192 constant slb_el 191 constant srt_el 217 constant srb_el \ Double frames 205 constant dh_el 186 constant dv_el 201 constant dlt_el 200 constant dlb_el 187 constant drt_el 188 constant drb_el \ Fillings 0 constant fill_none 32 constant fill_blank 176 constant fill_dark 177 constant fill_med 178 constant fill_bright : hline ( len x y -- ) \ Draw horizontal single line at-xy \ move cursor 0 do h_el @ emit loop ; : f_single ( -- ) \ set frames to single sh_el h_el ! sv_el v_el ! slt_el lt_el ! slb_el lb_el ! srt_el rt_el ! srb_el rb_el ! ; : f_double ( -- ) \ set frames to double dh_el h_el ! dv_el v_el ! dlt_el lt_el ! dlb_el lb_el ! drt_el rt_el ! drb_el rb_el ! ; : vline ( len x y -- ) \ Draw vertical single line 2dup 4 pick 0 do at-xy v_el @ emit 1+ 2dup loop 2drop 2drop drop ; : box ( w h x y -- ) \ Draw a box 2dup 1+ 4 pick 1- -rot vline \ Draw left vert line 2dup 1+ swap 5 pick + swap 4 pick 1- -rot vline \ Draw right vert line 2dup swap 1+ swap 5 pick 1- -rot hline \ Draw top horiz line 2dup swap 1+ swap 4 pick + 5 pick 1- -rot hline \ Draw bottom horiz line 2dup at-xy lt_el @ emit \ Draw left-top corner 2dup 4 pick + at-xy lb_el @ emit \ Draw left bottom corner 2dup swap 5 pick + swap at-xy rt_el @ emit \ Draw right top corner 2 pick + swap 3 pick + swap at-xy rb_el @ emit 2drop ; f_single fill_none fill ! diff --git a/share/examples/bootforth/loader.rc b/share/examples/bootforth/loader.rc index 617bc3db4104..e8aa549f5905 100644 --- a/share/examples/bootforth/loader.rc +++ b/share/examples/bootforth/loader.rc @@ -1,34 +1,33 @@ \ Example of the file which is automatically loaded by /boot/loader \ on startup. -\ $FreeBSD$ cr .( Loading Forth extensions:) \ Load configuration file words cr .( - loader.4th...) include /boot/loader.4th \ Load the screen manipulation words cr .( - screen.4th...) s" /boot/screen.4th" O_RDONLY fopen dup fload fclose \ Load frame support cr .( - frames.4th...) s" /boot/frames.4th" O_RDONLY fopen dup fload fclose \ Load our little menu cr .( - menuconf.4th...) s" /boot/menuconf.4th" O_RDONLY fopen dup fload fclose \ Initialize loader.4th stuff cr cr .( Initializing loader.4th...) initialize drop \ Show the menu cr main_menu diff --git a/share/examples/bootforth/menu.4th b/share/examples/bootforth/menu.4th index 5c5c3e98c74e..3462ea9fc5a9 100644 --- a/share/examples/bootforth/menu.4th +++ b/share/examples/bootforth/menu.4th @@ -1,99 +1,98 @@ \ Simple greeting screen, presenting basic options. \ XXX This is far too trivial - I don't have time now to think \ XXX about something more fancy... :-/ -\ $FreeBSD$ : title f_single 60 11 10 4 box 29 4 at-xy 15 fg 7 bg ." Welcome to BootFORTH!" me ; : menu 2 fg 20 7 at-xy ." 1. Start FreeBSD /kernel." 20 8 at-xy ." 2. Interact with BootFORTH." 20 9 at-xy ." 3. Reboot." me ; : tkey ( d -- flag | char ) seconds + begin 1 while dup seconds u< if drop -1 exit then key? if drop key exit then repeat ; : prompt 14 fg 20 11 at-xy ." Enter your option (1,2,3): " 10 tkey dup 32 = if drop key then dup 0< if drop 49 then dup emit me ; : help_text 10 18 at-xy ." * Choose 1 if you just want to run FreeBSD." 10 19 at-xy ." * Choose 2 if you want to use bootloader facilities." 12 20 at-xy ." See '?' for available commands, and 'words' for" 12 21 at-xy ." complete list of Forth words." 10 22 at-xy ." * Choose 3 in order to warm boot your machine." ; : (boot) 0 boot ; : (reboot) 0 reboot ; : main_menu begin 1 while clear f_double 79 23 1 1 box title menu help_text prompt cr cr cr dup 49 = if drop 1 25 at-xy cr ." Loading kernel. Please wait..." cr ['] (boot) catch abort" Error booting" then dup 50 = if drop 1 25 at-xy cr exit then dup 51 = if drop 1 25 at-xy cr ['] (reboot) catch abort" Error rebooting" then 20 12 at-xy ." Key " emit ." is not a valid option!" 20 13 at-xy ." Press any key to continue..." key drop repeat ; diff --git a/share/examples/bootforth/menuconf.4th b/share/examples/bootforth/menuconf.4th index a769f77e3543..df53e812aabc 100644 --- a/share/examples/bootforth/menuconf.4th +++ b/share/examples/bootforth/menuconf.4th @@ -1,110 +1,109 @@ \ Simple greeting screen, presenting basic options. \ XXX This is far too trivial - I don't have time now to think \ XXX about something more fancy... :-/ -\ $FreeBSD$ : title f_single 60 11 10 4 box 29 4 at-xy 15 fg 7 bg ." Welcome to BootFORTH!" me ; : menu 2 fg 20 7 at-xy ." 1. Start FreeBSD with /boot/stable.conf." 20 8 at-xy ." 2. Start FreeBSD with /boot/current.conf." 20 9 at-xy ." 3. Start FreeBSD with standard configuration. " 20 10 at-xy ." 4. Reboot." me ; : tkey ( d -- flag | char ) seconds + begin 1 while dup seconds u< if drop -1 exit then key? if drop key exit then repeat ; : prompt 14 fg 20 12 at-xy ." Enter your option (1,2,3,4): " 10 tkey dup 32 = if drop key then dup 0< if drop 51 then dup emit me ; : help_text 10 18 at-xy ." * Choose 1 or 2 to run special configuration file." 10 19 at-xy ." * Choose 3 to proceed with standard bootstrapping." 12 20 at-xy ." See '?' for available commands, and 'words' for" 12 21 at-xy ." complete list of Forth words." 10 22 at-xy ." * Choose 4 in order to warm boot your machine." ; : (reboot) 0 reboot ; : main_menu begin 1 while clear f_double 79 23 1 1 box title menu help_text prompt cr cr cr dup 49 = if drop 1 25 at-xy cr ." Loading /boot/stable.conf. Please wait..." cr s" /boot/stable.conf" read-conf 0 boot-conf exit then dup 50 = if drop 1 25 at-xy cr ." Loading /boot/current.conf. Please wait..." cr s" /boot/current.conf" read-conf 0 boot-conf exit then dup 51 = if drop 1 25 at-xy cr ." Proceeding with standard boot. Please wait..." cr 0 boot-conf exit then dup 52 = if drop 1 25 at-xy cr ['] (reboot) catch abort" Error rebooting" then 20 12 at-xy ." Key " emit ." is not a valid option!" 20 13 at-xy ." Press any key to continue..." key drop repeat ; diff --git a/share/examples/bootforth/screen.4th b/share/examples/bootforth/screen.4th index 3ea79e453d80..8bd873f48884 100644 --- a/share/examples/bootforth/screen.4th +++ b/share/examples/bootforth/screen.4th @@ -1,36 +1,35 @@ \ Screen manipulation related words. -\ $FreeBSD$ marker task-screen.4th : escc ( -- ) \ emit Esc-[ 91 27 emit emit ; : ho ( -- ) \ Home cursor escc 72 emit \ Esc-[H ; : cld ( -- ) \ Clear from current position to end of display escc 74 emit \ Esc-[J ; : clear ( -- ) \ clear screen ho cld ; : at-xy ( x y -- ) \ move cursor to x rows, y cols (1-based coords) escc .# 59 emit .# 72 emit \ Esc-[%d;%dH ; : fg ( x -- ) \ Set foreground color escc 3 .# .# 109 emit \ Esc-[3%dm ; : bg ( x -- ) \ Set background color escc 4 .# .# 109 emit \ Esc-[4%dm ; : me ( -- ) \ Mode end (clear attributes) escc 109 emit ; diff --git a/stand/ficl/softwords/classes.fr b/stand/ficl/softwords/classes.fr index b56da378e970..72524b0b9fa5 100644 --- a/stand/ficl/softwords/classes.fr +++ b/stand/ficl/softwords/classes.fr @@ -1,173 +1,172 @@ \ #if (FICL_WANT_OOP) \ ** ficl/softwords/classes.fr \ ** F I C L 2 . 0 C L A S S E S \ john sadler 1 sep 98 \ Needs oop.fr \ -\ $FreeBSD$ also oop definitions \ REF subclass holds a pointer to an object. It's \ mainly for aggregation to help in making data structures. \ object subclass c-ref cell: .class cell: .instance : get ( inst class -- refinst refclass ) drop 2@ ; : set ( refinst refclass inst class -- ) drop 2! ; end-class object subclass c-byte char: .payload : get drop c@ ; : set drop c! ; end-class object subclass c-2byte 2 chars: .payload : get drop w@ ; : set drop w! ; end-class object subclass c-4byte 4 chars: .payload : get drop q@ ; : set drop q! ; end-class object subclass c-cell cell: .payload : get drop @ ; : set drop ! ; end-class \ ** C - P T R \ Base class for pointers to scalars (not objects). \ Note: use c-ref to make references to objects. C-ptr \ subclasses refer to untyped quantities of various sizes. \ Derived classes must specify the size of the thing \ they point to, and supply get and set methods. \ All derived classes must define the @size method: \ @size ( inst class -- addr-units ) \ Returns the size in address units of the thing the pointer \ refers to. object subclass c-ptr c-cell obj: .addr \ get the value of the pointer : get-ptr ( inst class -- addr ) c-ptr => .addr c-cell => get ; \ set the pointer to address supplied : set-ptr ( addr inst class -- ) c-ptr => .addr c-cell => set ; \ force the pointer to be null : clr-ptr 0 -rot c-ptr => .addr c-cell => set ; \ return flag indicating null-ness : ?null ( inst class -- flag ) c-ptr => get-ptr 0= ; \ increment the pointer in place : inc-ptr ( inst class -- ) 2dup 2dup ( i c i c i c ) c-ptr => get-ptr -rot ( i c addr i c ) --> @size + -rot ( addr' i c ) c-ptr => set-ptr ; \ decrement the pointer in place : dec-ptr ( inst class -- ) 2dup 2dup ( i c i c i c ) c-ptr => get-ptr -rot ( i c addr i c ) --> @size - -rot ( addr' i c ) c-ptr => set-ptr ; \ index the pointer in place : index-ptr { index 2:this -- } this --> get-ptr ( addr ) this --> @size index * + ( addr' ) this --> set-ptr ; end-class \ ** C - C E L L P T R \ Models a pointer to cell (a 32 or 64 bit scalar). c-ptr subclass c-cellPtr : @size 2drop 1 cells ; \ fetch and store through the pointer : get ( inst class -- cell ) c-ptr => get-ptr @ ; : set ( value inst class -- ) c-ptr => get-ptr ! ; end-class \ ** C - 4 B Y T E P T R \ Models a pointer to a quadbyte scalar c-ptr subclass c-4bytePtr : @size 2drop 4 ; \ fetch and store through the pointer : get ( inst class -- value ) c-ptr => get-ptr q@ ; : set ( value inst class -- ) c-ptr => get-ptr q! ; end-class \ ** C - 2 B Y T E P T R \ Models a pointer to a 16 bit scalar c-ptr subclass c-2bytePtr : @size 2drop 2 ; \ fetch and store through the pointer : get ( inst class -- value ) c-ptr => get-ptr w@ ; : set ( value inst class -- ) c-ptr => get-ptr w! ; end-class \ ** C - B Y T E P T R \ Models a pointer to an 8 bit scalar c-ptr subclass c-bytePtr : @size 2drop 1 ; \ fetch and store through the pointer : get ( inst class -- value ) c-ptr => get-ptr c@ ; : set ( value inst class -- ) c-ptr => get-ptr c! ; end-class previous definitions \ #endif diff --git a/stand/ficl/softwords/ficlclass.fr b/stand/ficl/softwords/ficlclass.fr index 6d75efb0d3c5..471820c1ac8f 100644 --- a/stand/ficl/softwords/ficlclass.fr +++ b/stand/ficl/softwords/ficlclass.fr @@ -1,86 +1,85 @@ \ #if (FICL_WANT_OOP) \ ** ficl/softwords/ficlclass.fr \ Classes to model ficl data structures in objects \ This is a demo! \ John Sadler 14 Sep 1998 \ \ ** C - W O R D \ Models a FICL_WORD \ -\ $FreeBSD$ object subclass c-word c-word ref: .link c-2byte obj: .hashcode c-byte obj: .flags c-byte obj: .nName c-bytePtr obj: .pName c-cellPtr obj: .pCode c-4byte obj: .param0 \ Push word's name... : get-name ( inst class -- c-addr u ) 2dup my=[ .pName get-ptr ] -rot my=[ .nName get ] ; : next ( inst class -- link-inst class ) my=> .link ; : ? ." c-word: " 2dup --> get-name type cr ; end-class \ ** C - W O R D L I S T \ Models a FICL_HASH \ Example of use: \ get-current c-wordlist --> ref current \ current --> ? \ current --> .hash --> ? \ current --> .hash --> next --> ? object subclass c-wordlist c-wordlist ref: .parent c-ptr obj: .name c-cell obj: .size c-word ref: .hash ( first entry in hash table ) : ? --> get-name ." ficl wordlist " type cr ; : push drop >search ; : pop 2drop previous ; : set-current drop set-current ; : get-name drop wid-get-name ; : words { 2:this -- } this my=[ .size get ] 0 do i this my=[ .hash index ] ( 2list-head ) begin 2dup --> get-name type space --> next over 0= until 2drop cr loop ; end-class \ : named-wid wordlist postpone c-wordlist metaclass => ref ; \ ** C - F I C L S T A C K object subclass c-ficlstack c-4byte obj: .nCells c-cellPtr obj: .link c-cellPtr obj: .sp c-4byte obj: .stackBase : init 2drop ; : ? 2drop ." ficl stack " cr ; : top --> .sp --> .addr --> prev --> get ; end-class \ #endif diff --git a/stand/ficl/softwords/ficllocal.fr b/stand/ficl/softwords/ficllocal.fr index c916089696c1..86de6f9b6ea5 100644 --- a/stand/ficl/softwords/ficllocal.fr +++ b/stand/ficl/softwords/ficllocal.fr @@ -1,49 +1,48 @@ \ ** ficl/softwords/ficllocal.fr \ ** stack comment style local syntax... \ {{ a b c -- d e }} \ variables before the "--" are initialized in reverse order \ from the stack. Those after the "--" are zero initialized \ Uses locals... \ locstate: 0 = looking for -- or }} \ 1 = found -- \ -\ $FreeBSD$ hide 0 constant zero : ?-- s" --" compare 0= ; : ?}} s" }}" compare 0= ; set-current : {{ 0 dup locals| nLocs locstate | begin parse-word ?dup 0= abort" Error: out of text without seeing }}" 2dup 2dup ?-- -rot ?}} or 0= while nLocs 1+ to nLocs repeat ?-- if 1 to locstate endif nLocs 0 do (local) loop locstate 1 = if begin parse-word 2dup ?}} 0= while postpone zero (local) repeat 2drop endif 0 0 (local) ; immediate compile-only previous diff --git a/stand/ficl/softwords/fileaccess.fr b/stand/ficl/softwords/fileaccess.fr index 7297df681cf3..137058572f47 100644 --- a/stand/ficl/softwords/fileaccess.fr +++ b/stand/ficl/softwords/fileaccess.fr @@ -1,25 +1,24 @@ \ #if FICL_WANT_FILE \ ** \ ** File Access words for ficl \ ** submitted by Larry Hastings, larry@hastings.org \ ** \ -\ $FreeBSD$ : r/o 1 ; : r/w 3 ; : w/o 2 ; : bin 8 or ; : included r/o bin open-file 0= if locals| f | end-locals f include-file else drop endif ; : include parse-word included ; \ #endif diff --git a/stand/ficl/softwords/forml.fr b/stand/ficl/softwords/forml.fr index 1144ef536792..3e7e56ca2ec1 100644 --- a/stand/ficl/softwords/forml.fr +++ b/stand/ficl/softwords/forml.fr @@ -1,75 +1,74 @@ \ examples from FORML conference paper Nov 98 \ sadler \ -\ $FreeBSD$ .( loading FORML examples ) cr object --> sub c-example cell: .cell0 c-4byte obj: .nCells 4 c-4byte array: .quad c-byte obj: .length 79 chars: .name : init ( inst class -- ) 2dup object => init s" aardvark" 2swap --> set-name ; : get-name ( inst class -- c-addr u ) 2dup --> .name -rot ( c-addr inst class ) --> .length --> get ; : set-name { c-addr u 2:this -- } u this --> .length --> set c-addr this --> .name u move ; : ? ( inst class ) c-example => get-name type cr ; end-class : test ." this is a test" cr ; ' test c-word --> ref testref \ add a method to c-word... c-word --> get-wid ficl-set-current \ list dictionary thread : list ( inst class ) begin 2dup --> get-name type cr --> next over 0= until 2drop ; set-current object subclass c-led c-byte obj: .state : on { led# 2:this -- } this --> .state --> get 1 led# lshift or dup !oreg this --> .state --> set ; : off { led# 2:this -- } this --> .state --> get 1 led# lshift invert and dup !oreg this --> .state --> set ; end-class object subclass c-switch : ?on { bit# 2:this -- flag } 1 bit# lshift ; end-class diff --git a/stand/ficl/softwords/freebsd.fr b/stand/ficl/softwords/freebsd.fr index 96205c0808dd..948398b4e462 100644 --- a/stand/ficl/softwords/freebsd.fr +++ b/stand/ficl/softwords/freebsd.fr @@ -1,36 +1,35 @@ \ ** Copyright (c) 1998 Daniel C. Sobral \ ** All rights reserved. \ ** \ ** Redistribution and use in source and binary forms, with or without \ ** modification, are permitted provided that the following conditions \ ** are met: \ ** 1. Redistributions of source code must retain the above copyright \ ** notice, this list of conditions and the following disclaimer. \ ** 2. Redistributions in binary form must reproduce the above copyright \ ** notice, this list of conditions and the following disclaimer in the \ ** documentation and/or other materials provided with the distribution. \ ** \ ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ ** SUCH DAMAGE. \ ** -\ ** $FreeBSD$ \ Words for use in scripts: \ % ignore errors here \ $ echo this line : tib> source >in @ tuck over >in ! - >r + r> ; : % tib> ['] evaluate catch drop ; : $ tib> 2dup type cr evaluate ; \ ** E N D F R E E B S D . F R diff --git a/stand/ficl/softwords/ifbrack.fr b/stand/ficl/softwords/ifbrack.fr index a8c60626c4f8..b29b8fa08433 100644 --- a/stand/ficl/softwords/ifbrack.fr +++ b/stand/ficl/softwords/ifbrack.fr @@ -1,50 +1,49 @@ \ ** ficl/softwords/ifbrack.fr \ ** ANS conditional compile directives [if] [else] [then] \ ** Requires ficl 2.0 or greater... \ -\ $FreeBSD$ hide : ?[if] ( c-addr u -- c-addr u flag ) 2dup s" [if]" compare-insensitive 0= ; : ?[else] ( c-addr u -- c-addr u flag ) 2dup s" [else]" compare-insensitive 0= ; : ?[then] ( c-addr u -- c-addr u flag ) 2dup s" [then]" compare-insensitive 0= >r 2dup s" [endif]" compare-insensitive 0= r> or ; set-current : [else] ( -- ) 1 \ ( level ) begin begin parse-word dup while \ ( level addr len ) ?[if] if \ ( level addr len ) 2drop 1+ \ ( level ) else \ ( level addr len ) ?[else] if \ ( level addr len ) 2drop 1- dup if 1+ endif else ?[then] if 2drop 1- else 2drop endif endif endif ?dup 0= if exit endif \ level repeat 2drop \ level refill 0= until \ level drop ; immediate : [if] ( flag -- ) 0= if postpone [else] then ; immediate : [then] ( -- ) ; immediate : [endif] ( -- ) ; immediate previous diff --git a/stand/ficl/softwords/jhlocal.fr b/stand/ficl/softwords/jhlocal.fr index 12ccb9fea753..3cbeb78ff9a1 100644 --- a/stand/ficl/softwords/jhlocal.fr +++ b/stand/ficl/softwords/jhlocal.fr @@ -1,105 +1,104 @@ \ #if FICL_WANT_LOCALS \ ** ficl/softwords/jhlocal.fr \ ** stack comment style local syntax... \ { a b c | cleared -- d e } \ variables before the "|" are initialized in reverse order \ from the stack. Those after the "|" are zero initialized. \ Anything between "--" and "}" is treated as comment \ Uses locals... \ locstate: 0 = looking for | or -- or }} \ 1 = found | \ 2 = found -- \ 3 = found } \ 4 = end of line \ \ revised 2 June 2000 - { | a -- } now works correctly \ -\ $FreeBSD$ hide 0 constant zero : ?-- ( c-addr u -- c-addr u flag ) 2dup s" --" compare 0= ; : ?} ( c-addr u -- c-addr u flag ) 2dup s" }" compare 0= ; : ?| ( c-addr u -- c-addr u flag ) 2dup s" |" compare 0= ; \ examine name - if it's a 2local (starts with "2:"), \ nibble the prefix (the "2:") off the name and push true. \ Otherwise push false \ Problem if the local is named "2:" - we fall off the end... : ?2loc ( c-addr u -- c-addr u flag ) over dup c@ [char] 2 = swap 1+ c@ [char] : = and if 2 - swap char+ char+ swap \ dcs/jws: nibble the '2:' true else false endif ; : ?delim ( c-addr u -- state | c-addr u 0 ) ?| if 2drop 1 exit endif ?-- if 2drop 2 exit endif ?} if 2drop 3 exit endif dup 0= if 2drop 4 exit endif 0 ; set-current : { 0 dup locals| locstate | \ stack locals until we hit a delimiter begin parse-word \ ( nLocals c-addr u ) ?delim dup to locstate 0= while rot 1+ \ ( c-addr u ... c-addr u nLocals ) repeat \ now unstack the locals 0 ?do ?2loc if (2local) else (local) endif loop \ ( ) \ zero locals until -- or } locstate 1 = if begin parse-word ?delim dup to locstate 0= while ?2loc if postpone zero postpone zero (2local) else postpone zero (local) endif repeat endif 0 0 (local) \ toss words until } \ (explicitly allow | and -- in the comment) locstate 2 = if begin parse-word ?delim dup to locstate 3 < while locstate 0= if 2drop endif repeat endif locstate 3 <> abort" syntax error in { } local line" ; immediate compile-only previous \ #endif diff --git a/stand/ficl/softwords/marker.fr b/stand/ficl/softwords/marker.fr index ee3c9bdf2f64..3b9e86acaaf0 100644 --- a/stand/ficl/softwords/marker.fr +++ b/stand/ficl/softwords/marker.fr @@ -1,27 +1,26 @@ \ ** ficl/softwords/marker.fr \ ** Ficl implementation of CORE EXT MARKER \ John Sadler, 4 Oct 98 \ Requires ficl 2.02 FORGET-WID !! \ -\ $FreeBSD$ : marker ( "name" -- ) create get-current , get-order dup , 0 ?do , loop does> 0 set-order \ clear search order dup body> >name drop here - allot \ reset HERE to my xt-addr dup @ ( pfa current-wid ) dup set-current forget-wid ( pfa ) cell+ dup @ swap ( count count-addr ) over cells + swap ( last-wid-addr count ) 0 ?do dup @ dup ( wid-addr wid wid ) >search forget-wid ( wid-addr ) cell- loop drop ; diff --git a/stand/ficl/softwords/oo.fr b/stand/ficl/softwords/oo.fr index b1c8e214e5bd..0857cbe4b9fb 100644 --- a/stand/ficl/softwords/oo.fr +++ b/stand/ficl/softwords/oo.fr @@ -1,694 +1,693 @@ \ #if FICL_WANT_OOP \ ** ficl/softwords/oo.fr \ ** F I C L O - O E X T E N S I O N S \ ** john sadler aug 1998 \ -\ $FreeBSD$ 17 ficl-vocabulary oop also oop definitions \ Design goals: \ 0. Traditional OOP: late binding by default for safety. \ Early binding if you ask for it. \ 1. Single inheritance \ 2. Object aggregation (has-a relationship) \ 3. Support objects in the dictionary and as proxies for \ existing structures (by reference): \ *** A ficl object can wrap a C struct *** \ 4. Separate name-spaces for methods - methods are \ only visible in the context of a class / object \ 5. Methods can be overridden, and subclasses can add methods. \ No limit on number of methods. \ General info: \ Classes are objects, too: all classes are instances of METACLASS \ All classes are derived (by convention) from OBJECT. This \ base class provides a default initializer and superclass \ access method \ A ficl object binds instance storage (payload) to a class. \ object ( -- instance class ) \ All objects push their payload address and class address when \ executed. \ A ficl class consists of a parent class pointer, a wordlist \ ID for the methods of the class, and a size for the payload \ of objects created by the class. A class is an object. \ The NEW method creates and initializes an instance of a class. \ Classes have this footprint: \ cell 0: parent class address \ cell 1: wordlist ID \ cell 2: size of instance's payload \ Methods expect an object couple ( instance class ) \ on the stack. This is by convention - ficl has no way to \ police your code to make sure this is always done, but it \ happens naturally if you use the facilities presented here. \ \ Overridden methods must maintain the same stack signature as \ their predecessors. Ficl has no way of enforcing this, either. \ \ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now \ has an extra field for the vtable method count. Hasvtable declares \ refs to vtable classes \ \ Revised Nov 2001 - metaclass debug method now finds only metaclass methods \ \ Planned: Ficl vtable support \ Each class has a vtable size parameter \ END-CLASS allocates and clears the vtable - then it walks class's method \ list and inserts all new methods into table. For each method, if the table \ slot is already nonzero, do nothing (overridden method). Otherwise fill \ vtable slot. Now do same check for parent class vtable, filling only \ empty slots in the new vtable. \ Methods are now structured as follows: \ - header \ - vtable index \ - xt \ :noname definition for code \ \ : is redefined to check for override, fill in vtable index, increment method \ count if not an override, create header and fill in index. Allot code pointer \ and run :noname \ ; is overridden to fill in xt returned by :noname \ --> compiles code to fetch vtable address, offset by index, and execute \ => looks up xt in the vtable and compiles it directly user current-class 0 current-class ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** L A T E B I N D I N G \ Compile the method name, and code to find and \ execute it at run-time... \ \ p a r s e - m e t h o d \ compiles a method name so that it pushes \ the string base address and count at run-time. : parse-method \ name run: ( -- c-addr u ) parse-word postpone sliteral ; compile-only : (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 } class name class cell+ @ ( class c-addr u wid ) search-wordlist ; \ l o o k u p - m e t h o d \ takes a counted string method name from the stack (as compiled \ by parse-method) and attempts to look this method up in the method list of \ the class that's on the stack. If successful, it leaves the class on the stack \ and pushes the xt of the method. If not, it aborts with an error message. : lookup-method { class 2:name -- class xt } class name (lookup-method) ( 0 | xt 1 | xt -1 ) 0= if name type ." not found in " class body> >name type cr abort endif ; : find-method-xt \ name ( class -- class xt ) parse-word lookup-method ; : catch-method ( instance class c-addr u -- exc-flag ) lookup-method catch ; : exec-method ( instance class c-addr u -- ) lookup-method execute ; \ Method lookup operator takes a class-addr and instance-addr \ and executes the method from the class's wordlist if \ interpreting. If compiling, bind late. \ : --> ( instance class -- ??? ) state @ 0= if find-method-xt execute else parse-method postpone exec-method endif ; immediate \ Method lookup with CATCH in case of exceptions : c-> ( instance class -- ?? exc-flag ) state @ 0= if find-method-xt catch else parse-method postpone catch-method endif ; immediate \ METHOD makes global words that do method invocations by late binding \ in case you prefer this style (no --> in your code) \ Example: everything has next and prev for array access, so... \ method next \ method prev \ my-instance next ( does whatever next does to my-instance by late binding ) : method create does> body> >name lookup-method execute ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** E A R L Y B I N D I N G \ Early binding operator compiles code to execute a method \ given its class at compile time. Classes are immediate, \ so they leave their cell-pair on the stack when compiling. \ Example: \ : get-wid metaclass => .wid @ ; \ Usage \ my-class get-wid ( -- wid-of-my-class ) \ 1 ficl-named-wordlist instance-vars instance-vars dup >search ficl-set-current : => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method drop find-method-xt compile, drop ; immediate compile-only : my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class current-class @ dup postpone => ; immediate compile-only \ Problem: my=[ assumes that each method except the last is am obj: member \ which contains its class as the first field of its parameter area. The code \ detects non-obect members and assumes the class does not change in this case. \ This handles methods like index, prev, and next correctly, but does not deal \ correctly with CLASS. : my=[ \ same as my=> , but binds a chain of methods current-class @ begin parse-word 2dup ( class c-addr u c-addr u ) s" ]" compare while ( class c-addr u ) lookup-method ( class xt ) dup compile, ( class xt ) dup ?object if \ If object member, get new class. Otherwise assume same class nip >body cell+ @ ( new-class ) else drop ( class ) endif repeat 2drop drop ; immediate compile-only \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** I N S T A N C E V A R I A B L E S \ Instance variables (IV) are represented by words in the class's \ private wordlist. Each IV word contains the offset \ of the IV it represents, and runs code to add that offset \ to the base address of an instance when executed. \ The metaclass SUB method, defined below, leaves the address \ of the new class's offset field and its initial size on the \ stack for these words to update. When a class definition is \ complete, END-CLASS saves the final size in the class's size \ field, and restores the search order and compile wordlist to \ prior state. Note that these words are hidden in their own \ wordlist to prevent accidental use outside a SUB END-CLASS pair. \ : do-instance-var does> ( instance class addr[offset] -- addr[field] ) nip @ + ; : addr-units: ( offset size "name" -- offset' ) create over , + do-instance-var ; : chars: \ ( offset nCells "name" -- offset' ) Create n char member. chars addr-units: ; : char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 1 chars: ; : cells: ( offset nCells "name" -- offset' ) cells >r aligned r> addr-units: ; : cell: ( offset nCells "name" -- offset' ) 1 cells: ; \ Aggregate an object into the class... \ Needs the class of the instance to create \ Example: object obj: m_obj \ : do-aggregate objectify does> ( instance class pfa -- a-instance a-class ) 2@ ( inst class a-class a-offset ) 2swap drop ( a-class a-offset inst ) + swap ( a-inst a-class ) ; : obj: { offset class meta -- offset' } \ "name" create offset , class , class meta --> get-size offset + do-aggregate ; \ Aggregate an array of objects into a class \ Usage example: \ 3 my-class array: my-array \ Makes an instance variable array of 3 instances of my-class \ named my-array. \ : array: ( offset n class meta "name" -- offset' ) locals| meta class nobjs offset | create offset , class , class meta --> get-size nobjs * offset + do-aggregate ; \ Aggregate a pointer to an object: REF is a member variable \ whose class is set at compile time. This is useful for wrapping \ data structures in C, where there is only a pointer and the type \ it refers to is known. If you want polymorphism, see c_ref \ in classes.fr. REF is only useful for pre-initialized structures, \ since there's no supported way to set one. : ref: ( offset class meta "name" -- offset' ) locals| meta class offset | create offset , class , offset cell+ does> ( inst class pfa -- ptr-inst ptr-class ) 2@ ( inst class ptr-class ptr-offset ) 2swap drop + @ swap ; \ #if FICL_WANT_VCALL \ vcall extensions contributed by Guy Carver : vcall: ( paramcnt "name" -- ) current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. create , , \ ( paramcnt index -- ) does> \ ( inst class pfa -- ptr-inst ptr-class ) nip 2@ vcall \ ( params offset inst class offset -- ) ; : vcallr: 0x80000000 or vcall: ; \ Call with return address desired. \ #if FICL_WANT_FLOAT : vcallf: \ ( paramcnt -- f: r ) 0x80000000 or current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. create , , \ ( paramcnt index -- ) does> \ ( inst class pfa -- ptr-inst ptr-class ) nip 2@ vcall f> \ ( params offset inst class offset -- f: r ) ; \ #endif /* FLOAT */ \ #endif /* VCALL */ \ END-CLASS terminates construction of a class by storing \ the size of its instance variables in the class's size field \ ( -- old-wid addr[size] 0 ) \ : end-class ( old-wid addr[size] size -- ) swap ! set-current search> drop \ pop struct builder wordlist ; \ See resume-class (a metaclass method) below for usage \ This is equivalent to end-class for now, but that will change \ when we support vtable bindings. : suspend-class ( old-wid addr[size] size -- ) end-class ; set-current previous \ E N D I N S T A N C E V A R I A B L E S \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ D O - D O - I N S T A N C E \ Makes a class method that contains the code for an \ instance of the class. This word gets compiled into \ the wordlist of every class by the SUB method. \ PRECONDITION: current-class contains the class address \ why use a state variable instead of the stack? \ >> Stack state is not well-defined during compilation (there are \ >> control structure match codes on the stack, of undefined size \ >> easiest way around this is use of this thread-local variable \ : do-do-instance ( -- ) s" : .do-instance does> [ current-class @ ] literal ;" evaluate ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** M E T A C L A S S \ Every class is an instance of metaclass. This lets \ classes have methods that are different from those \ of their instances. \ Classes are IMMEDIATE to make early binding simpler \ See above... \ :noname wordlist create immediate 0 , \ NULL parent class dup , \ wid \ #if FICL_WANT_VCALL 4 cells , \ instance size \ #else 3 cells , \ instance size \ #endif ficl-set-current does> dup ; execute metaclass \ now brand OBJECT's wordlist (so that ORDER can display it by name) metaclass drop cell+ @ brand-wordlist metaclass drop current-class ! do-do-instance \ \ C L A S S M E T H O D S \ instance-vars >search create .super ( class metaclass -- parent-class ) 0 cells , do-instance-var create .wid ( class metaclass -- wid ) \ return wid of class 1 cells , do-instance-var \ #if FICL_WANT_VCALL create .vtCount \ Number of VTABLE methods, if any 2 cells , do-instance-var create .size ( class metaclass -- size ) \ return class's payload size 3 cells , do-instance-var \ #else create .size ( class metaclass -- size ) \ return class's payload size 2 cells , do-instance-var \ #endif : get-size metaclass => .size @ ; : get-wid metaclass => .wid @ ; : get-super metaclass => .super @ ; \ #if FICL_WANT_VCALL : get-vtCount metaclass => .vtCount @ ; : get-vtAdd metaclass => .vtCount ; \ #endif \ create an uninitialized instance of a class, leaving \ the address of the new instance and its class \ : instance ( class metaclass "name" -- instance class ) locals| meta parent | create here parent --> .do-instance \ ( inst class ) parent meta metaclass => get-size allot \ allocate payload space ; \ create an uninitialized array : array ( n class metaclass "name" -- n instance class ) locals| meta parent nobj | create nobj here parent --> .do-instance \ ( nobj inst class ) parent meta metaclass => get-size nobj * allot \ allocate payload space ; \ create an initialized instance \ : new \ ( class metaclass "name" -- ) metaclass => instance --> init ; \ create an initialized array of instances : new-array ( n class metaclass "name" -- ) metaclass => array --> array-init ; \ Create an anonymous initialized instance from the heap : alloc \ ( class metaclass -- instance class ) locals| meta class | class meta metaclass => get-size allocate ( -- addr fail-flag ) abort" allocate failed " ( -- addr ) class 2dup --> init ; \ Create an anonymous array of initialized instances from the heap : alloc-array \ ( n class metaclass -- instance class ) locals| meta class nobj | class meta metaclass => get-size nobj * allocate ( -- addr fail-flag ) abort" allocate failed " ( -- addr ) nobj over class --> array-init class ; \ Create an anonymous initialized instance from the dictionary : allot { 2:this -- 2:instance } here ( instance-address ) this my=> get-size allot this drop 2dup --> init ; \ Create an anonymous array of initialized instances from the dictionary : allot-array { nobj 2:this -- 2:instance } here ( instance-address ) this my=> get-size nobj * allot this drop 2dup ( 2instance 2instance ) nobj -rot --> array-init ; \ create a proxy object with initialized payload address given : ref ( instance-addr class metaclass "name" -- ) drop create , , does> 2@ ; \ suspend-class and resume-class help to build mutually referent classes. \ Example: \ object subclass c-akbar \ suspend-class ( put akbar on hold while we define jeff ) \ object subclass c-jeff \ c-akbar ref: .akbar \ ( and whatever else comprises this class ) \ end-class ( done with c-jeff ) \ c-akbar --> resume-class \ c-jeff ref: .jeff \ ( and whatever else goes in c-akbar ) \ end-class ( done with c-akbar ) \ : resume-class { 2:this -- old-wid addr[size] size } this --> .wid @ ficl-set-current ( old-wid ) this --> .size dup @ ( old-wid addr[size] size ) instance-vars >search ; \ create a subclass \ This method leaves the stack and search order ready for instance variable \ building. Pushes the instance-vars wordlist onto the search order, \ and sets the compilation wordlist to be the private wordlist of the \ new class. The class's wordlist is deliberately NOT in the search order - \ to prevent methods from getting used with wrong data. \ Postcondition: leaves the address of the new class in current-class : sub ( class metaclass "name" -- old-wid addr[size] size ) wordlist locals| wid meta parent | parent meta metaclass => get-wid wid wid-set-super \ set superclass create immediate \ get the subclass name wid brand-wordlist \ label the subclass wordlist here current-class ! \ prep for do-do-instance parent , \ save parent class wid , \ save wid \ #if FICL_WANT_VCALL parent meta --> get-vtCount , \ #endif here parent meta --> get-size dup , ( addr[size] size ) metaclass => .do-instance wid ficl-set-current -rot do-do-instance instance-vars >search \ push struct builder wordlist ; \ OFFSET-OF returns the offset of an instance variable \ from the instance base address. If the next token is not \ the name of in instance variable method, you get garbage \ results -- there is no way at present to check for this error. : offset-of ( class metaclass "name" -- offset ) drop find-method-xt nip >body @ ; \ ID returns the string name cell-pair of its class : id ( class metaclass -- c-addr u ) drop body> >name ; \ list methods of the class : methods \ ( class meta -- ) locals| meta class | begin class body> >name type ." methods:" cr class meta --> get-wid >search words cr previous class meta metaclass => get-super dup to class 0= until cr ; \ list class's ancestors : pedigree ( class meta -- ) locals| meta class | begin class body> >name type space class meta metaclass => get-super dup to class 0= until cr ; \ decompile an instance method : see ( class meta -- ) metaclass => get-wid >search see previous ; \ debug a method of metaclass \ Eg: my-class --> debug my-method : debug ( class meta -- ) find-method-xt debug-xt ; previous set-current \ E N D M E T A C L A S S \ ** META is a nickname for the address of METACLASS... metaclass drop constant meta \ ** SUBCLASS is a nickname for a class's SUB method... \ Subclass compilation ends when you invoke end-class \ This method is late bound for safety... : subclass --> sub ; \ #if FICL_WANT_VCALL \ VTABLE Support extensions (Guy Carver) \ object --> sub mine hasvtable : hasvtable 4 + ; immediate \ #endif \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** O B J E C T \ Root of all classes :noname wordlist create immediate 0 , \ NULL parent class dup , \ wid 0 , \ instance size ficl-set-current does> meta ; execute object \ now brand OBJECT's wordlist (so that ORDER can display it by name) object drop cell+ @ brand-wordlist object drop current-class ! do-do-instance instance-vars >search \ O B J E C T M E T H O D S \ Convert instance cell-pair to class cell-pair \ Useful for binding class methods from an instance : class ( instance class -- class metaclass ) nip meta ; \ default INIT method zero fills an instance : init ( instance class -- ) meta metaclass => get-size ( inst size ) erase ; \ Apply INIT to an array of NOBJ objects... \ : array-init ( nobj inst class -- ) 0 dup locals| &init &next class inst | \ \ bind methods outside the loop to save time \ class s" init" lookup-method to &init s" next" lookup-method to &next drop 0 ?do inst class 2dup &init execute &next execute drop to inst loop ; \ free storage allocated to a heap instance by alloc or alloc-array \ NOTE: not protected against errors like FREEing something that's \ really in the dictionary. : free \ ( instance class -- ) drop free abort" free failed " ; \ Instance aliases for common class methods \ Upcast to parent class : super ( instance class -- instance parent-class ) meta metaclass => get-super ; : pedigree ( instance class -- ) object => class metaclass => pedigree ; : size ( instance class -- sizeof-instance ) object => class metaclass => get-size ; : methods ( instance class -- ) object => class metaclass => methods ; \ Array indexing methods... \ Usage examples: \ 10 object-array --> index \ obj --> next \ : index ( n instance class -- instance[n] class ) locals| class inst | inst class object => class metaclass => get-size * ( n*size ) inst + class ; : next ( instance[n] class -- instance[n+1] class ) locals| class inst | inst class object => class metaclass => get-size inst + class ; : prev ( instance[n] class -- instance[n-1] class ) locals| class inst | inst class object => class metaclass => get-size inst swap - class ; : debug ( 2this -- ?? ) find-method-xt debug-xt ; previous set-current \ E N D O B J E C T \ reset to default search order only definitions \ redefine oop in default search order to put OOP words in the search order and make them \ the compiling wordlist... : oo only also oop definitions ; \ #endif diff --git a/stand/ficl/softwords/prefix.fr b/stand/ficl/softwords/prefix.fr index ae1727fc00bc..b1491a384425 100644 --- a/stand/ficl/softwords/prefix.fr +++ b/stand/ficl/softwords/prefix.fr @@ -1,59 +1,58 @@ \ ** \ ** Prefix words for ficl \ ** submitted by Larry Hastings, larry@hastings.org \ ** \ (jws) To make a prefix, simply create a new definition in the \ wordlist. start-prefixes and end-prefixes handle the bookkeeping \ -\ $FreeBSD$ variable save-current : start-prefixes get-current save-current ! set-current ; : end-prefixes save-current @ set-current ; : show-prefixes >search words search> drop ; \ #if (FICL_EXTENDED_PREFIX) start-prefixes \ define " (double-quote) as an alias for s", and make it a prefix : " postpone s" ; immediate \ make .( a prefix (we just create an alias for it in the prefixes list) : .( postpone .( ; immediate \ make \ a prefix, and add // (same thing) as a prefix too \ (jws) "//" is precompiled to save aggravation with Perl \ : // postpone \ ; immediate \ ** add 0b, 0o, 0d, and 0x as prefixes \ ** these temporarily shift the base to 2, 8, 10, and 16 respectively \ ** and consume the next number in the input stream, pushing/compiling \ ** as normal \ (jws) __tempbase is precompiled, as are 0x and 0d - see prefix.c \ \ : __tempbase { newbase | oldbase -- } \ base @ to oldbase \ newbase base ! \ 0 0 parse-word >number 2drop drop \ oldbase base ! \ ; : 0b 2 __tempbase ; immediate : 0o 8 __tempbase ; immediate \ : 0d 10 __tempbase ; immediate \ "0d" add-prefix \ : 0x 16 __tempbase ; immediate \ "0x" add-prefix end-prefixes \ #endif diff --git a/stand/ficl/softwords/softcore.fr b/stand/ficl/softwords/softcore.fr index 3ec74d8cbece..1350f859f3a2 100644 --- a/stand/ficl/softwords/softcore.fr +++ b/stand/ficl/softwords/softcore.fr @@ -1,240 +1,239 @@ \ ** ficl/softwords/softcore.fr \ ** FICL soft extensions \ ** John Sadler (john_sadler@alum.mit.edu) \ ** September, 1998 \ -\ $FreeBSD$ \ ** Ficl USER variables \ ** See words.c for primitive def'n of USER \ #if FICL_WANT_USER variable nUser 0 nUser ! : user \ name ( -- ) nUser dup @ user 1 swap +! ; \ #endif \ ** ficl extras \ EMPTY cleans the parameter stack : empty ( xn..x1 -- ) depth 0 ?do drop loop ; \ CELL- undoes CELL+ : cell- ( addr -- addr ) [ 1 cells ] literal - ; : -rot ( a b c -- c a b ) 2 -roll ; \ ** CORE : abs ( x -- x ) dup 0< if negate endif ; decimal 32 constant bl : space ( -- ) bl emit ; : spaces ( n -- ) 0 ?do space loop ; : abort" state @ if postpone if postpone ." postpone cr -2 postpone literal postpone throw postpone endif else [char] " parse rot if type cr -2 throw else 2drop endif endif ; immediate \ ** CORE EXT 0 constant false false invert constant true : <> = 0= ; : 0<> 0= 0= ; : compile, , ; : convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970 : erase ( addr u -- ) 0 fill ; variable span : expect ( c-addr u1 -- ) accept span ! ; \ see marker.fr for MARKER implementation : nip ( y x -- x ) swap drop ; : tuck ( y x -- x y x) swap over ; : within ( test low high -- flag ) over - >r - r> u< ; : u.r ( n +n -- ) swap 0 <# #s #> rot over - dup 0< if drop else spaces then type space ; \ ** LOCAL EXT word set \ #if FICL_WANT_LOCALS : locals| ( name...name | -- ) begin bl word count dup 0= abort" where's the delimiter??" over c@ [char] | - over 1- or while (local) repeat 2drop 0 0 (local) ; immediate : local ( name -- ) bl word count (local) ; immediate : 2local ( name -- ) bl word count (2local) ; immediate : end-locals ( -- ) 0 0 (local) ; immediate \ #endif \ ** TOOLS word set... : ? ( addr -- ) @ . ; Variable /dump : i' ( R:w R:w2 -- R:w R:w2 w ) r> r> r> dup >r swap >r swap >r ; : .4 ( addr -- addr' ) 4 0 DO -1 /dump +! /dump @ 0< IF 3 spaces ELSE dup c@ 0 <# # # #> type space THEN char+ LOOP ; : .chars ( addr -- ) /dump @ over + swap ?DO I c@ dup 127 bl within IF drop [char] . THEN emit LOOP ; : .line ( addr -- ) dup .4 space .4 ." - " .4 space .4 drop 16 /dump +! space .chars ; : dump ( addr u -- ) \ tools dump cr base @ >r hex \ save base on return stack 0 ?DO I' I - 16 min /dump ! dup 8 u.r ." : " dup .line cr 16 + 16 +LOOP drop r> base ! ; \ ** SEARCH+EXT words and ficl helpers \ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom: \ wordlist dup create , brand-wordlist \ gets the name of the word made by create and applies it to the wordlist... : brand-wordlist ( wid -- ) last-word >name drop wid-set-name ; : ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid ) ficl-wordlist dup create , brand-wordlist does> @ ; : wordlist ( -- ) 1 ficl-wordlist ; \ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value : ficl-set-current ( wid -- old-wid ) get-current swap set-current ; \ DO_VOCABULARY handles the DOES> part of a VOCABULARY \ When executed, new voc replaces top of search stack : do-vocabulary ( -- ) does> @ search> drop >search ; : ficl-vocabulary ( nBuckets name -- ) ficl-named-wordlist do-vocabulary ; : vocabulary ( name -- ) 1 ficl-vocabulary ; \ PREVIOUS drops the search order stack : previous ( -- ) search> drop ; \ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace \ USAGE: \ hide \ \ set-current \