summaryrefslogtreecommitdiff
path: root/softwords
diff options
context:
space:
mode:
Diffstat (limited to 'softwords')
-rw-r--r--softwords/classes.fr172
-rw-r--r--softwords/ficlclass.fr84
-rw-r--r--softwords/ficllocal.fr46
-rw-r--r--softwords/fileaccess.fr23
-rw-r--r--softwords/forml.fr72
-rw-r--r--softwords/ifbrack.fr48
-rw-r--r--softwords/jhlocal.fr103
-rw-r--r--softwords/makefile9
-rw-r--r--softwords/marker.fr25
-rw-r--r--softwords/oo.fr693
-rw-r--r--softwords/oo.fr.bak678
-rw-r--r--softwords/prefix.fr57
-rw-r--r--softwords/softcore.bat1
-rw-r--r--softwords/softcore.fr207
-rwxr-xr-xsoftwords/softcore.pl144
-rw-r--r--softwords/softcore.py152
-rw-r--r--softwords/softcore.py.bat1
-rw-r--r--softwords/string.fr148
-rw-r--r--softwords/win32.fr10
19 files changed, 0 insertions, 2673 deletions
diff --git a/softwords/classes.fr b/softwords/classes.fr
deleted file mode 100644
index 1a00cc95b913..000000000000
--- a/softwords/classes.fr
+++ /dev/null
@@ -1,172 +0,0 @@
-\ #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
-
-.( loading ficl utility classes ) cr
-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/softwords/ficlclass.fr b/softwords/ficlclass.fr
deleted file mode 100644
index 5922c6e19aae..000000000000
--- a/softwords/ficlclass.fr
+++ /dev/null
@@ -1,84 +0,0 @@
-\ #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
-
-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/softwords/ficllocal.fr b/softwords/ficllocal.fr
deleted file mode 100644
index 9381247edfc4..000000000000
--- a/softwords/ficllocal.fr
+++ /dev/null
@@ -1,46 +0,0 @@
-\ ** 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 --
-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/softwords/fileaccess.fr b/softwords/fileaccess.fr
deleted file mode 100644
index 7a4452ac7e75..000000000000
--- a/softwords/fileaccess.fr
+++ /dev/null
@@ -1,23 +0,0 @@
-\ #if FICL_WANT_FILE
-\ **
-\ ** File Access words for ficl
-\ ** submitted by Larry Hastings, larry@hastings.org
-\ **
-
-: 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/softwords/forml.fr b/softwords/forml.fr
deleted file mode 100644
index cc684e086131..000000000000
--- a/softwords/forml.fr
+++ /dev/null
@@ -1,72 +0,0 @@
-\ examples from FORML conference paper Nov 98
-\ sadler
-.( 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/softwords/ifbrack.fr b/softwords/ifbrack.fr
deleted file mode 100644
index af276b8e0947..000000000000
--- a/softwords/ifbrack.fr
+++ /dev/null
@@ -1,48 +0,0 @@
-\ ** ficl/softwords/ifbrack.fr
-\ ** ANS conditional compile directives [if] [else] [then]
-\ ** Requires ficl 2.0 or greater...
-
-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/softwords/jhlocal.fr b/softwords/jhlocal.fr
deleted file mode 100644
index a6e946a36462..000000000000
--- a/softwords/jhlocal.fr
+++ /dev/null
@@ -1,103 +0,0 @@
-\ #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
-.( loading Johns-Hopkins locals ) cr
-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/softwords/makefile b/softwords/makefile
deleted file mode 100644
index 55edd857cb7b..000000000000
--- a/softwords/makefile
+++ /dev/null
@@ -1,9 +0,0 @@
-SOURCES = softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr
-
-softcore.c: softcore.pl $(SOURCES)
- ./softcore.pl $(SOURCES) >softcore.c
- cp softcore.c ..
-
-clean:
- rm *.c
-
diff --git a/softwords/marker.fr b/softwords/marker.fr
deleted file mode 100644
index 0f2ee5eaf493..000000000000
--- a/softwords/marker.fr
+++ /dev/null
@@ -1,25 +0,0 @@
-\ ** ficl/softwords/marker.fr
-\ ** Ficl implementation of CORE EXT MARKER
-\ John Sadler, 4 Oct 98
-\ Requires ficl 2.02 FORGET-WID !!
-.( loading MARKER ) cr
-: 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/softwords/oo.fr b/softwords/oo.fr
deleted file mode 100644
index 31ab7e3d816d..000000000000
--- a/softwords/oo.fr
+++ /dev/null
@@ -1,693 +0,0 @@
-\ #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
-
-.( loading ficl O-O extensions ) cr
-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/softwords/oo.fr.bak b/softwords/oo.fr.bak
deleted file mode 100644
index afe8edb38b80..000000000000
--- a/softwords/oo.fr.bak
+++ /dev/null
@@ -1,678 +0,0 @@
-\ #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
-
-.( loading ficl O-O extensions ) cr
-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 August 2001 - 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...
-\
-
-hide
-
-\ 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
-
-\ 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 }
- name class cell+ @ ( c-addr u wid )
- search-wordlist ( 0 | xt 1 | xt -1 )
- 0= if
- name type ." not found in "
- class body> >name type
- cr abort
- endif
- class swap
-;
-
-: find-method-xt \ name ( class -- class xt )
- parse-word lookup-method
-;
-
-set-current ( stop hiding definitions )
-
-: 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
-
-: my=[ \ same as my=> , but binds a chain of methods
- current-class @
- begin
- parse-word 2dup
- s" ]" compare while ( class c-addr u )
- lookup-method nip dup ( xt xt )
- compile, >body cell+ @ ( class' )
- 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
- 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 "name" -- offset' )
- locals| meta class offset |
- 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-object --> 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...
-: oop only also oop definitions ;
-\ #endif \ No newline at end of file
diff --git a/softwords/prefix.fr b/softwords/prefix.fr
deleted file mode 100644
index 7ccd14f0cb14..000000000000
--- a/softwords/prefix.fr
+++ /dev/null
@@ -1,57 +0,0 @@
-\ **
-\ ** 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
-
-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/softwords/softcore.bat b/softwords/softcore.bat
deleted file mode 100644
index 85633280495f..000000000000
--- a/softwords/softcore.bat
+++ /dev/null
@@ -1 +0,0 @@
-perl softcore.pl softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
diff --git a/softwords/softcore.fr b/softwords/softcore.fr
deleted file mode 100644
index 14bc065af073..000000000000
--- a/softwords/softcore.fr
+++ /dev/null
@@ -1,207 +0,0 @@
-\ ** ficl/softwords/softcore.fr
-\ ** FICL soft extensions
-\ ** John Sadler (john_sadler@alum.mit.edu)
-\ ** September, 1998
-
-\ ** Ficl USER variables
-\ ** See words.c for primitive def'n of USER
-.( loading ficl soft extensions ) cr
-\ #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
-.( loading CORE EXT words ) cr
-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
-.( loading SEARCH & SEARCH-EXT words ) cr
-\ 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/softwords/softcore.pl b/softwords/softcore.pl
deleted file mode 100755
index cb521ad9ec3b..000000000000
--- a/softwords/softcore.pl
+++ /dev/null
@@ -1,144 +0,0 @@
-#! /usr/bin/perl
-# Convert forth source files to a giant C string
-
-$now = localtime;
-
-print <<EOF
-/*******************************************************************
-** s o f t c o r e . c
-** Forth Inspired Command Language -
-** Words from CORE set written in FICL
-** Author: John Sadler (john_sadler\@alum.mit.edu)
-** Created: 27 December 1997
-** Last update: $now
-*******************************************************************/
-/*
-** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.pl
-** Make changes to the .fr files in ficl/softwords instead.
-** This file contains definitions that are compiled into the
-** system dictionary by the first virtual machine to be created.
-** Created automagically by ficl/softwords/softcore.pl
-*/
-/*
-** Copyright (c) 1997-2001 John Sadler (john_sadler\@alum.mit.edu)
-** All rights reserved.
-**
-** Get the latest Ficl release at http://ficl.sourceforge.net
-**
-** I am interested in hearing from anyone who uses ficl. If you have
-** a problem, a success story, a defect, an enhancement request, or
-** if you would like to contribute to the ficl release, please send
-** contact me by email at the address above.
-**
-** L I C E N S E and D I S C L A I M E R
-**
-** 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.
-*/
-
-
-#include "ficl.h"
-
-static char softWords[] =
-#if FICL_WANT_SOFTWORDS
-EOF
-;
-
-$commenting = 0;
-
-while (<>) {
- s"\n$""; # remove EOL
- s/\"/\\\"/g; # escape quotes
-
- #
- # emit lines beginnning with "\ **" as C comments
- #
- if (/^\\\s\*\*/) {
- s"^\\ "";
- if ($commenting == 0) {
- print "/*\n";
- }
- $commenting = 1;
- print "$_\n";
- next;
- }
-
- if ($commenting == 1) {
- print "*/\n";
- }
-
- $commenting = 0;
-
- #
- # ignore empty lines and lines containing
- # only empty comments
- #
- next if /^\s*\\\s*$/;
- next if /^\s*$/;
-
- #
- # pass commented preprocessor directives
- # == lines starting with "\ #"
- # (supports single line directives only)
- #
- if (/^\\\s#/) {
- s"^\\ "";
- print "$_\n";
- next;
- }
-
- next if /^\s*\\ /; # toss all other \ comment lines
- s"\\\s+.*$"" ; # lop off trailing \ comments
- s"\s+\(\s.*?\)""g; # delete ( ) comments
- s"^\s+""; # remove leading spaces
- s"\s+$""; # remove trailing spaces
-
- #
- # emit whatever's left as quoted string fragments
- #
-# $out = " \"" . $_ . " \\n\"";
- $out = " \"" . $_ . " \"";
- print "$out\n";
-}
-
-print <<EOF
-#endif /* WANT_SOFTWORDS */
- "quit ";
-
-
-void ficlCompileSoftCore(FICL_SYSTEM *pSys)
-{
- FICL_VM *pVM = pSys->vmList;
- CELL id = pVM->sourceID;
- int ret = sizeof (softWords);
- assert(pVM);
- pVM->sourceID.i = -1;
- ret = ficlExec(pVM, softWords);
- pVM->sourceID = id;
- if (ret == VM_ERREXIT)
- assert(FALSE);
- return;
-}
-
-
-EOF
-;
-
diff --git a/softwords/softcore.py b/softwords/softcore.py
deleted file mode 100644
index f5f3d8dc9cc3..000000000000
--- a/softwords/softcore.py
+++ /dev/null
@@ -1,152 +0,0 @@
-#! python
-# Convert forth source files to a giant C string
-
-import re;
-import sys;
-import time;
-
-
-print """/*******************************************************************
-** s o f t c o r e . c
-** Forth Inspired Command Language -
-** Words from CORE set written in FICL
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 27 December 1997
-** Last update: """ + time.ctime(time.time()) + """
-*******************************************************************/
-/*
-** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.py
-** Make changes to the .fr files in ficl/softwords instead.
-** This file contains definitions that are compiled into the
-** system dictionary by the first virtual machine to be created.
-** Created automagically by ficl/softwords/softcore.py
-*/
-/*
-** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
-** All rights reserved.
-**
-** Get the latest Ficl release at http://ficl.sourceforge.net
-**
-** I am interested in hearing from anyone who uses ficl. If you have
-** a problem, a success story, a defect, an enhancement request, or
-** if you would like to contribute to the ficl release, please send
-** contact me by email at the address above.
-**
-** L I C E N S E and D I S C L A I M E R
-**
-** 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.
-*/
-
-
-#include "ficl.h"
-
-static char softWords[] =
-#if FICL_WANT_SOFTWORDS"""
-
-escapedQuotes = re.compile( r'^"(.*)"$' )
-backslash = re.compile( r'^(.*[^\s])\s+\\(\s+[^\s].*)$' )
-parentheses = re.compile( r'^(.*[^\s])\s+\(\s[^)]+\)(\s+[^\s].*)?$' )
-
-
-commenting = 0;
-
-for a in (sys.argv[1:]):
- f = open(a)
- for line in f.readlines():
-
- # trim all whitespace
- line = line.strip();
-
- # remove quotes around quoted lines
- quoted = escapedQuotes.match(line)
- if (quoted != None):
- line = quoted.group(1).strip()
-
- #
- # emit lines beginnning with "\ **" as C comments
- #
- if (line[0:4] == "\\ **"):
- if (commenting == 0):
- print("/*")
- commenting = 1
- print(line[2:])
- continue
-
- if (commenting == 1):
- print "*/"
-
- commenting = 0
-
- # ignore empty lines
- if (len(line) == 0):
- continue
-
- # pass commented preprocessor directives
- # == lines starting with "\ #"
- # (supports single line directives only)
- if (line[0:3] == "\\ #"):
- print(line[2:]) # include the leading #!
- continue
-
- # ignore remaining lines starting with comments
- if (line[0] == "\\"):
- continue
-
- # remove trailing comments
- trailingComment = backslash.match(line)
- if (trailingComment != None):
- line = trailingComment.group(1)
-
- # remove ( comments ) in the middle
- embeddedComment = parentheses.match(line)
- if (embeddedComment != None):
- line = embeddedComment.group(1)
- if (embeddedComment.lastindex >= 2):
- line = line + " " + embeddedComment.group(2).strip()
-
- # quote double-quote characters
- line = line.replace("\"", "\\\"")
-
- # emit whatever's left as quoted string fragments
- print(" \"" + line + " \"");
-
-
-print """#endif /* WANT_SOFTWORDS */
- "quit ";
-
-
-void ficlCompileSoftCore(FICL_SYSTEM *pSys)
-{
- FICL_VM *pVM = pSys->vmList;
- CELL id = pVM->sourceID;
- int ret = sizeof (softWords);
- assert(pVM);
- pVM->sourceID.i = -1;
- ret = ficlExec(pVM, softWords);
- pVM->sourceID = id;
- if (ret == VM_ERREXIT)
- assert(FALSE);
- return;
-}
-
-
-"""
diff --git a/softwords/softcore.py.bat b/softwords/softcore.py.bat
deleted file mode 100644
index 20ada6f0bc9b..000000000000
--- a/softwords/softcore.py.bat
+++ /dev/null
@@ -1 +0,0 @@
-python softcore.py softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
diff --git a/softwords/string.fr b/softwords/string.fr
deleted file mode 100644
index e7f2c698f2f4..000000000000
--- a/softwords/string.fr
+++ /dev/null
@@ -1,148 +0,0 @@
-\ #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
-\
-
-.( loading ficl string class ) cr
-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
diff --git a/softwords/win32.fr b/softwords/win32.fr
deleted file mode 100644
index b34f4e329481..000000000000
--- a/softwords/win32.fr
+++ /dev/null
@@ -1,10 +0,0 @@
-\ **
-\ ** win32.fr
-\ ** submitted by Larry Hastings, larry@hastings.org
-\ **
-
-
-\ ** simple wrappers for callnativeFunction that specify the calling convention
-: callcfunction 1 callnativeFunction ;
-: callpascalfunction 0 callnativeFunction ;
-
generated by cgit v1.3 (git 2.53.0) at 2026-03-29 23:52:02 +0000