diff options
author | kevans <kevans@FreeBSD.org> | 2018-02-12 01:08:44 +0000 |
---|---|---|
committer | kevans <kevans@FreeBSD.org> | 2018-02-12 01:08:44 +0000 |
commit | 7d97ee5b28b409c00bfaf12daf5ab497a6038b9d (patch) | |
tree | 245306b754606bcf49c0ff17b131b58609b6c7a6 /stand/ficl/softwords | |
parent | 43b278e1b66cf4de337a17034087ea785031bd6f (diff) | |
download | FreeBSD-src-7d97ee5b28b409c00bfaf12daf5ab497a6038b9d.zip FreeBSD-src-7d97ee5b28b409c00bfaf12daf5ab497a6038b9d.tar.gz |
MFC r325834,r325997,326502: Move sys/boot to stand/
This is effectively a direct commit to stable/11, due to differences between
stable/11 and head. Changes to DTS in sys/boot/fdt/dts were often
accompanied by kernel changes. Many of these were also risc-v updates that
likely had many more dependencies to MFC.
Because of this, sys/boot/fdt/dts remains as-is while everything else in
sys/boot relocates to stand/.
r325834: Move sys/boot to stand. Fix all references to new location
r325997: Remove empty directories.
r326502: Document the sys/boot -> stand move in hier.7 and the top-level README.
Diffstat (limited to 'stand/ficl/softwords')
-rw-r--r-- | stand/ficl/softwords/classes.fr | 173 | ||||
-rw-r--r-- | stand/ficl/softwords/ficlclass.fr | 86 | ||||
-rw-r--r-- | stand/ficl/softwords/ficllocal.fr | 49 | ||||
-rw-r--r-- | stand/ficl/softwords/fileaccess.fr | 25 | ||||
-rw-r--r-- | stand/ficl/softwords/forml.fr | 75 | ||||
-rw-r--r-- | stand/ficl/softwords/freebsd.fr | 36 | ||||
-rw-r--r-- | stand/ficl/softwords/ifbrack.fr | 50 | ||||
-rw-r--r-- | stand/ficl/softwords/jhlocal.fr | 105 | ||||
-rw-r--r-- | stand/ficl/softwords/marker.fr | 27 | ||||
-rw-r--r-- | stand/ficl/softwords/oo.fr | 694 | ||||
-rw-r--r-- | stand/ficl/softwords/prefix.fr | 59 | ||||
-rw-r--r-- | stand/ficl/softwords/softcore.awk | 183 | ||||
-rw-r--r-- | stand/ficl/softwords/softcore.fr | 206 | ||||
-rw-r--r-- | stand/ficl/softwords/string.fr | 148 |
14 files changed, 1916 insertions, 0 deletions
diff --git a/stand/ficl/softwords/classes.fr b/stand/ficl/softwords/classes.fr new file mode 100644 index 0000000..b56da37 --- /dev/null +++ b/stand/ficl/softwords/classes.fr @@ -0,0 +1,173 @@ +\ #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 new file mode 100644 index 0000000..6d75efb --- /dev/null +++ b/stand/ficl/softwords/ficlclass.fr @@ -0,0 +1,86 @@ +\ #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 new file mode 100644 index 0000000..c916089 --- /dev/null +++ b/stand/ficl/softwords/ficllocal.fr @@ -0,0 +1,49 @@ +\ ** 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 new file mode 100644 index 0000000..7297df6 --- /dev/null +++ b/stand/ficl/softwords/fileaccess.fr @@ -0,0 +1,25 @@ +\ #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 new file mode 100644 index 0000000..1144ef5 --- /dev/null +++ b/stand/ficl/softwords/forml.fr @@ -0,0 +1,75 @@ +\ 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 new file mode 100644 index 0000000..96205c0 --- /dev/null +++ b/stand/ficl/softwords/freebsd.fr @@ -0,0 +1,36 @@ +\ ** Copyright (c) 1998 Daniel C. Sobral <dcs@freebsd.org> +\ ** 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 new file mode 100644 index 0000000..a8c6062 --- /dev/null +++ b/stand/ficl/softwords/ifbrack.fr @@ -0,0 +1,50 @@ +\ ** 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 new file mode 100644 index 0000000..12ccb9f --- /dev/null +++ b/stand/ficl/softwords/jhlocal.fr @@ -0,0 +1,105 @@ +\ #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 new file mode 100644 index 0000000..ee3c9bd --- /dev/null +++ b/stand/ficl/softwords/marker.fr @@ -0,0 +1,27 @@ +\ ** 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 new file mode 100644 index 0000000..b1c8e21 --- /dev/null +++ b/stand/ficl/softwords/oo.fr @@ -0,0 +1,694 @@ +\ #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 -- <method-signature> exc-flag ) + lookup-method catch +; + +: exec-method ( instance class c-addr u -- <method-signature> ) + 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 -<name>- 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 new file mode 100644 index 0000000..ae1727f --- /dev/null +++ b/stand/ficl/softwords/prefix.fr @@ -0,0 +1,59 @@ +\ ** +\ ** Prefix words for ficl +\ ** submitted by Larry Hastings, larry@hastings.org +\ ** +\ (jws) To make a prefix, simply create a new definition in the <prefixes> +\ wordlist. start-prefixes and end-prefixes handle the bookkeeping +\ +\ $FreeBSD$ + +variable save-current + +: start-prefixes get-current save-current ! <prefixes> set-current ; +: end-prefixes save-current @ set-current ; +: show-prefixes <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.awk b/stand/ficl/softwords/softcore.awk new file mode 100644 index 0000000..5a97999 --- /dev/null +++ b/stand/ficl/softwords/softcore.awk @@ -0,0 +1,183 @@ +#!/usr/bin/awk -f +# +# Convert forth source files to a giant C string +# +# Joe Abley <jabley@patho.gen.nz>, 12 January 1999 +# +# 02-oct-1999: Cleaned up awk slightly; added some additional logic +# suggested by dcs to compress the stored forth program. +# +# Note! This script uses strftime() which is a gawk-ism, and the +# POSIX [[:space:]] character class. +# +# $FreeBSD$ + +BEGIN \ +{ + printf "/*******************************************************************\n"; + printf "** s o f t c o r e . c\n"; + printf "** Forth Inspired Command Language -\n"; + printf "** Words from CORE set written in FICL\n"; + printf "** Author: John Sadler (john_sadler@alum.mit.edu)\n"; + printf "** Created: 27 December 1997\n"; + printf "** Last update: %s\n", datestamp; + printf "*******************************************************************/\n"; + printf "/*\n"; + printf "** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.awk\n"; + printf "** Make changes to the .fr files in ficl/softwords instead.\n"; + printf "** This file contains definitions that are compiled into the\n"; + printf "** system dictionary by the first virtual machine to be created.\n"; + printf "** Created automagically by ficl/softwords/softcore.awk\n"; + printf "*/\n"; + printf "/*\n"; + printf "** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)\n"; + printf "** All rights reserved.\n"; + printf "**\n"; + printf "** Get the latest Ficl release at http://ficl.sourceforge.net\n"; + printf "**\n"; + printf "** I am interested in hearing from anyone who uses ficl. If you have\n"; + printf "** a problem, a success story, a defect, an enhancement request, or\n"; + printf "** if you would like to contribute to the ficl release, please send\n"; + printf "** contact me by email at the address above.\n"; + printf "**\n"; + printf "** L I C E N S E and D I S C L A I M E R\n"; + printf "** \n"; + printf "** Redistribution and use in source and binary forms, with or without\n"; + printf "** modification, are permitted provided that the following conditions\n"; + printf "** are met:\n"; + printf "** 1. Redistributions of source code must retain the above copyright\n"; + printf "** notice, this list of conditions and the following disclaimer.\n"; + printf "** 2. Redistributions in binary form must reproduce the above copyright\n"; + printf "** notice, this list of conditions and the following disclaimer in the\n"; + printf "** documentation and/or other materials provided with the distribution.\n"; + printf "**\n"; + printf "** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND\n"; + printf "** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\n"; + printf "** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\n"; + printf "** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE\n"; + printf "** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\n"; + printf "** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS\n"; + printf "** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)\n"; + printf "** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT\n"; + printf "** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY\n"; + printf "** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF\n"; + printf "** SUCH DAMAGE.\n"; + printf "*/\n"; + printf "\n"; + printf "\n#include \"ficl.h\"\n"; + printf "\nstatic char softWords[] =\n"; + printf "#if FICL_WANT_SOFTWORDS\n"; + + commenting = 0; +} + +# some general early substitutions +{ + gsub(/\t/, " "); # replace each tab with 4 spaces + gsub(/\"/, "\\\""); # escape quotes + gsub(/\\[[:space:]]+$/, ""); # toss empty comments +} + +# strip out empty lines +/^ *$/ \ +{ + next; +} + +# emit / ** lines as multi-line C comments +/^\\[[:space:]]\*\*/ \ +{ + sub(/^\\[[:space:]]/, ""); + if (commenting == 0) printf "/*\n"; + printf "%s\n", $0; + commenting = 1; + next; +} + +# strip blank lines +/^[[:space:]]*$/ \ +{ + next; +} + +# function to close a comment, used later +function end_comments() +{ + commenting = 0; + printf "*/\n"; +} + +# pass commented preprocessor directives +/^\\[[:space:]]#/ \ +{ + if (commenting) end_comments(); + sub(/^\\[[:space:]]/, ""); + printf "%s\n", $0; + next; +} + +# toss all other full-line \ comments +/^\\/ \ +{ + if (commenting) end_comments(); + next; +} + +# lop off trailing \ comments +/\\[[:space:]]+/ \ +{ + sub(/\\[[:space:]]+.*$/, ""); +} + +# expunge ( ) comments +/[[:space:]]+\([[:space:]][^)]*\)/ \ +{ + sub(/[[:space:]]+\([[:space:]][^)]*\)/, ""); +} + +# remove leading spaces +/^[[:space:]]+/ \ +{ + sub(/^[[:space:]]+/, ""); +} + +# removing trailing spaces +/[[:space:]]+$/ \ +{ + sub(/[[:space:]]+$/, ""); +} + +# strip out empty lines again (preceding rules may have generated some) +/^[[:space:]]*$/ \ +{ + if (commenting) end_comments(); + next; +} + +# emit all other lines as quoted string fragments +{ + if (commenting) end_comments(); + + printf " \"%s \"\n", $0; + next; +} + +END \ +{ + if (commenting) end_comments(); + printf "#endif /* WANT_SOFTWORDS */\n"; + printf " \"quit \";\n"; + printf "\n\nvoid ficlCompileSoftCore(FICL_SYSTEM *pSys)\n"; + printf "{\n"; + printf " FICL_VM *pVM = pSys->vmList;\n"; + printf " CELL id = pVM->sourceID;\n"; + printf " int ret = sizeof (softWords);\n"; + printf " assert(pVM);\n"; + printf " pVM->sourceID.i = -1;\n"; + printf " ret = ficlExec(pVM, softWords);\n"; + printf " pVM->sourceID = id;\n"; + printf " if (ret == VM_ERREXIT)\n"; + printf " assert(FALSE);\n"; + printf " return;\n"; + printf "}\n"; +} diff --git a/stand/ficl/softwords/softcore.fr b/stand/ficl/softwords/softcore.fr new file mode 100644 index 0000000..a70ebaa --- /dev/null +++ b/stand/ficl/softwords/softcore.fr @@ -0,0 +1,206 @@ +\ ** 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< ; + + +\ ** 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 -- ) @ . ; +: dump ( addr u -- ) + 0 ?do + dup c@ . 1+ + i 7 and 7 = if cr endif + loop drop +; + +\ ** 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 +\ <definitions to hide> +\ set-current +\ <words that use hidden defs> +\ previous ( pop HIDDEN off the search order ) + +1 ficl-named-wordlist hidden +: hide hidden dup >search ficl-set-current ; + +\ ALSO dups the search stack... +: also ( -- ) + search> dup >search >search ; + +\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST +: forth ( -- ) + search> drop + forth-wordlist >search ; + +\ ONLY sets the search order to a default state +: only ( -- ) + -1 set-order ; + +\ ORDER displays the compile wid and the search order list +hide +: list-wid ( wid -- ) + dup wid-get-name ( wid c-addr u ) + ?dup if + type drop + else + drop ." (unnamed wid) " x. + endif cr +; +set-current \ stop hiding words + +: order ( -- ) + ." Search:" cr + get-order 0 ?do 3 spaces list-wid loop cr + ." Compile: " get-current list-wid cr +; + +: debug ' debug-xt ; immediate +: on-step ." S: " .s cr ; + + +\ Submitted by lch. +: strdup ( c-addr length -- c-addr2 length2 ior ) + 0 locals| addr2 length c-addr | end-locals + length 1 + allocate + 0= if + to addr2 + c-addr addr2 length move + addr2 length 0 + else + 0 -1 + endif + ; + +: strcat ( 2:a 2:b -- 2:new-a ) + 0 locals| b-length b-u b-addr a-u a-addr | end-locals + b-u to b-length + b-addr a-addr a-u + b-length move + a-addr a-u b-length + + ; + +: strcpy ( 2:a 2:b -- 2:new-a ) + locals| b-u b-addr a-u a-addr | end-locals + a-addr 0 b-addr b-u strcat + ; + + +previous \ lose hidden words from search order + +\ ** E N D S O F T C O R E . F R + diff --git a/stand/ficl/softwords/string.fr b/stand/ficl/softwords/string.fr new file mode 100644 index 0000000..dabb390 --- /dev/null +++ b/stand/ficl/softwords/string.fr @@ -0,0 +1,148 @@ +\ #if (FICL_WANT_OOP) +\ ** ficl/softwords/string.fr +\ A useful dynamic string class +\ John Sadler 14 Sep 1998 +\ +\ ** C - S T R I N G +\ counted string, buffer sized dynamically +\ Creation example: +\ c-string --> new str +\ s" arf arf!!" str --> set +\ s" woof woof woof " str --> cat +\ str --> type cr +\ +\ $FreeBSD$ + +also oop definitions + +object subclass c-string + c-cell obj: .count + c-cell obj: .buflen + c-ptr obj: .buf + 32 constant min-buf + + : get-count ( 2:this -- count ) my=[ .count get ] ; + : set-count ( count 2:this -- ) my=[ .count set ] ; + + : ?empty ( 2:this -- flag ) --> get-count 0= ; + + : get-buflen ( 2:this -- len ) my=[ .buflen get ] ; + : set-buflen ( len 2:this -- ) my=[ .buflen set ] ; + + : get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ; + : set-buf { ptr len 2:this -- } + ptr this my=[ .buf set-ptr ] + len this my=> set-buflen + ; + + \ set buffer to null and buflen to zero + : clr-buf ( 2:this -- ) + 0 0 2over my=> set-buf + 0 -rot my=> set-count + ; + + \ free the buffer if there is one, set buf pointer to null + : free-buf { 2:this -- } + this my=> get-buf + ?dup if + free + abort" c-string free failed" + this my=> clr-buf + endif + ; + + \ guarantee buffer is large enough to hold size chars + : size-buf { size 2:this -- } + size 0< abort" need positive size for size-buf" + size 0= if + this --> free-buf exit + endif + + \ force buflen to be a positive multiple of min-buf chars + my=> min-buf size over / 1+ * chars to size + + \ if buffer is null, allocate one, else resize it + this --> get-buflen 0= + if + size allocate + abort" out of memory" + size this --> set-buf + size this --> set-buflen + exit + endif + + size this --> get-buflen > if + this --> get-buf size resize + abort" out of memory" + size this --> set-buf + endif + ; + + : set { c-addr u 2:this -- } + u this --> size-buf + u this --> set-count + c-addr this --> get-buf u move + ; + + : get { 2:this -- c-addr u } + this --> get-buf + this --> get-count + ; + + \ append string to existing one + : cat { c-addr u 2:this -- } + this --> get-count u + dup >r + this --> size-buf + c-addr this --> get-buf this --> get-count + u move + r> this --> set-count + ; + + : type { 2:this -- } + this --> ?empty if ." (empty) " exit endif + this --> .buf --> get-ptr + this --> .count --> get + type + ; + + : compare ( 2string 2:this -- n ) + --> get + 2swap + --> get + 2swap compare + ; + + : hashcode ( 2:this -- hashcode ) + --> get hash + ; + + \ destructor method (overrides object --> free) + : free ( 2:this -- ) 2dup --> free-buf object => free ; + +end-class + +c-string subclass c-hashstring + c-2byte obj: .hashcode + + : set-hashcode { 2:this -- } + this --> super --> hashcode + this --> .hashcode --> set + ; + + : get-hashcode ( 2:this -- hashcode ) + --> .hashcode --> get + ; + + : set ( c-addr u 2:this -- ) + 2swap 2over --> super --> set + --> set-hashcode + ; + + : cat ( c-addr u 2:this -- ) + 2swap 2over --> super --> cat + --> set-hashcode + ; + +end-class + +previous definitions +\ #endif |