summaryrefslogtreecommitdiffstats
path: root/stand/ficl/softwords
diff options
context:
space:
mode:
Diffstat (limited to 'stand/ficl/softwords')
-rw-r--r--stand/ficl/softwords/classes.fr173
-rw-r--r--stand/ficl/softwords/ficlclass.fr86
-rw-r--r--stand/ficl/softwords/ficllocal.fr49
-rw-r--r--stand/ficl/softwords/fileaccess.fr25
-rw-r--r--stand/ficl/softwords/forml.fr75
-rw-r--r--stand/ficl/softwords/freebsd.fr36
-rw-r--r--stand/ficl/softwords/ifbrack.fr50
-rw-r--r--stand/ficl/softwords/jhlocal.fr105
-rw-r--r--stand/ficl/softwords/marker.fr27
-rw-r--r--stand/ficl/softwords/oo.fr694
-rw-r--r--stand/ficl/softwords/prefix.fr59
-rw-r--r--stand/ficl/softwords/softcore.awk183
-rw-r--r--stand/ficl/softwords/softcore.fr206
-rw-r--r--stand/ficl/softwords/string.fr148
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
OpenPOWER on IntegriCloud