summaryrefslogtreecommitdiff
path: root/softcore
diff options
context:
space:
mode:
Diffstat (limited to 'softcore')
-rw-r--r--softcore/classes.fr172
-rw-r--r--softcore/ficl.fr67
-rw-r--r--softcore/ficlclass.fr84
-rw-r--r--softcore/ficllocal.fr46
-rw-r--r--softcore/fileaccess.fr22
-rw-r--r--softcore/forml.fr72
-rw-r--r--softcore/ifbrack.fr48
-rw-r--r--softcore/jhlocal.fr171
-rw-r--r--softcore/make.bat22
-rw-r--r--softcore/makefile11
-rw-r--r--softcore/makesoftcore.c244
-rw-r--r--softcore/marker.fr25
-rw-r--r--softcore/oo.fr700
-rw-r--r--softcore/prefix.fr47
-rw-r--r--softcore/softcore.fr152
-rw-r--r--softcore/string.fr149
-rw-r--r--softcore/win32.fr211
17 files changed, 2243 insertions, 0 deletions
diff --git a/softcore/classes.fr b/softcore/classes.fr
new file mode 100644
index 000000000000..44a486322086
--- /dev/null
+++ b/softcore/classes.fr
@@ -0,0 +1,172 @@
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** 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/softcore/ficl.fr b/softcore/ficl.fr
new file mode 100644
index 000000000000..d90bd3b16957
--- /dev/null
+++ b/softcore/ficl.fr
@@ -0,0 +1,67 @@
+\ ** ficl/softwords/softcore.fr
+\ ** FICL soft extensions
+\ ** John Sadler (john_sadler@alum.mit.edu)
+\ ** September, 1998
+
+S" FICL_WANT_USER" ENVIRONMENT? drop [if]
+\ ** Ficl USER variables
+\ ** See words.c for primitive def'n of USER
+variable nUser 0 nUser !
+: user \ name ( -- )
+ nUser dup @ user 1 swap +! ;
+
+[endif]
+
+
+
+S" FICL_WANT_LOCALS" ENVIRONMENT? drop [if]
+
+\ ** LOCAL EXT word set
+
+: 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
+
+
+\ 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
+ ;
+
+[endif]
+
+\ end-of-file
+
diff --git a/softcore/ficlclass.fr b/softcore/ficlclass.fr
new file mode 100644
index 000000000000..35cf31982cbe
--- /dev/null
+++ b/softcore/ficlclass.fr
@@ -0,0 +1,84 @@
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** 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/softcore/ficllocal.fr b/softcore/ficllocal.fr
new file mode 100644
index 000000000000..bd8a24bdec73
--- /dev/null
+++ b/softcore/ficllocal.fr
@@ -0,0 +1,46 @@
+\ ** 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/softcore/fileaccess.fr b/softcore/fileaccess.fr
new file mode 100644
index 000000000000..2673fefc0767
--- /dev/null
+++ b/softcore/fileaccess.fr
@@ -0,0 +1,22 @@
+S" FICL_WANT_FILE" ENVIRONMENT? drop [if]
+\ **
+\ ** 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
+ include-file
+ else
+ drop
+ endif
+ ;
+
+: include parse-word included ;
+
+[endif]
diff --git a/softcore/forml.fr b/softcore/forml.fr
new file mode 100644
index 000000000000..a26480b94698
--- /dev/null
+++ b/softcore/forml.fr
@@ -0,0 +1,72 @@
+\ 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/softcore/ifbrack.fr b/softcore/ifbrack.fr
new file mode 100644
index 000000000000..35c9e72b724d
--- /dev/null
+++ b/softcore/ifbrack.fr
@@ -0,0 +1,48 @@
+\ ** 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/softcore/jhlocal.fr b/softcore/jhlocal.fr
new file mode 100644
index 000000000000..775ecf5d9f76
--- /dev/null
+++ b/softcore/jhlocal.fr
@@ -0,0 +1,171 @@
+S" FICL_WANT_LOCALS" ENVIRONMENT? drop [if]
+\ ** 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
+
+\ What does this do? It's equivalent to "postpone 0", but faster.
+\ "ficlInstruction0" is the FICL instruction for "push a 0 on the data stack".
+\ --lch
+: compiled-zero ficlInstruction0 , ;
+\ And this is the instruction for a floating-point 0 (0.0e).
+: compiled-float-zero ficlInstructionF0 , ;
+
+
+: ?-- ( 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= ;
+
+1 constant local-is-double
+2 constant local-is-float
+
+\ parse-local-prefix-flags
+\
+\ Parses single-letter prefix flags from the name of a local, and returns
+\ a bitfield of all flags (local-is-float | local-is-double) appropriate
+\ for the local. Adjusts the "c-addr u" of the name to remove any prefix.
+\
+\ Handled single-letter prefix flags:
+\ 1 single-cell
+\ 2 double-cell
+\ d double-cell
+\ f floating-point (use floating stack)
+\ i integer (use data stack)
+\ s single-cell
+\ Specify as many as you like; later flags have precidence.
+\ Thus, "f2:foo" and "2is2f:foo" are both double-cell floats.
+\
+\ If you don't specify anything after the colon, like "f2:",
+\ there is no legal prefix, so "2f:" becomes the name of the
+\ (single-cell data stack) local.
+\
+\ For convention, the "f" is preferred first.
+
+: parse-local-prefix-flags ( c-addr u -- c-addr u flags )
+ 0 0 0 locals| stop-loop colon-offset flags u c-addr |
+
+ \ if the first character is a colon, remove the colon and return 0.
+ c-addr c@ [char] : =
+ if
+ over over 0 exit
+ endif
+
+ u 0 do
+ c-addr i + c@
+ case
+ [char] 1 of flags local-is-double invert and to flags endof
+ [char] 2 of flags local-is-double or to flags endof
+ [char] d of flags local-is-double or to flags endof
+ [char] f of flags local-is-float or to flags endof
+ [char] i of flags local-is-float invert and to flags endof
+ [char] s of flags local-is-double invert and to flags endof
+ [char] : of i 1+ to colon-offset 1 to stop-loop endof
+ 1 to stop-loop
+ endcase
+ stop-loop if leave endif
+ loop
+
+ colon-offset 0=
+ colon-offset u =
+ or
+ if
+\ ." Returning variable name -- " c-addr u type ." -- No flags." cr
+ c-addr u 0 exit
+ endif
+
+ c-addr colon-offset +
+ u colon-offset -
+\ ." Returning variable name -- " 2dup type ." -- Flags: " flags . cr
+ flags
+;
+
+: ?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 0 0 locals| flags local-state nLocals |
+
+ \ stack locals until we hit a delimiter
+ begin
+ parse-word ?delim dup to local-state
+ 0= while
+ nLocals 1+ to nLocals
+ repeat
+
+ \ now unstack the locals
+ nLocals 0 ?do
+ parse-local-prefix-flags to flags
+ flags local-is-double and if
+ flags local-is-float and if (f2local) else (2local) endif
+ else
+ flags local-is-float and if (flocal) else (local) endif
+ endif
+ loop \ ( )
+
+ \ zero locals until -- or }
+ local-state 1 = if
+ begin
+ parse-word
+ ?delim dup to local-state
+ 0= while
+ parse-local-prefix-flags to flags
+ flags local-is-double and if
+ flags local-is-float and if
+ compiled-float-zero compiled-float-zero (f2local)
+ else
+ compiled-zero compiled-zero (2local)
+ endif
+ else
+ flags local-is-float and if
+ compiled-float-zero (flocal)
+ else
+ compiled-zero (local)
+ endif
+ endif
+ repeat
+ endif
+
+ 0 0 (local)
+
+ \ toss words until }
+ \ (explicitly allow | and -- in the comment)
+ local-state 2 = if
+ begin
+ parse-word
+ ?delim dup to local-state
+ 3 < while
+ local-state 0= if 2drop endif
+ repeat
+ endif
+
+ local-state 3 <> abort" syntax error in { } local line"
+; immediate compile-only
+
+previous
+[endif]
+
diff --git a/softcore/make.bat b/softcore/make.bat
new file mode 100644
index 000000000000..8dedfc0830eb
--- /dev/null
+++ b/softcore/make.bat
@@ -0,0 +1,22 @@
+@echo off
+
+if "%1" == "clean" goto CLEAN
+
+if exist makesoftcore.exe goto SKIPCL
+cl /Zi /Od makesoftcore.c ..\lzcompress.c ..\bit.c
+goto MAKESOFTCORE
+
+:SKIPCL
+echo makesoftcore.exe exists, skipping building it.
+
+:MAKESOFTCORE
+echo on
+makesoftcore softcore.fr ifbrack.fr prefix.fr ficl.fr jhlocal.fr marker.fr oo.fr classes.fr string.fr win32.fr ficllocal.fr fileaccess.fr
+goto EXIT
+
+:CLEAN
+del *.obj
+del makesoftcore.exe
+del ..\softcore.c
+
+:EXIT
diff --git a/softcore/makefile b/softcore/makefile
new file mode 100644
index 000000000000..d686f17a62fb
--- /dev/null
+++ b/softcore/makefile
@@ -0,0 +1,11 @@
+SOURCES = softcore.fr ifbrack.fr prefix.fr ficl.fr jhlocal.fr marker.fr oo.fr classes.fr string.fr ficllocal.fr fileaccess.fr
+
+../softcore.c: makesoftcore $(SOURCES)
+ makesoftcore $(SOURCES)
+
+makesoftcore: makesoftcore.c ../lzcompress.c ../bit.c
+ $(CC) $(CFLAGS) $(CPPFLAGS) -I.. -o makesoftcore makesoftcore.c ../lzcompress.c ../bit.c
+
+clean:
+ - rm ../softcore.c *.o makesoftcore
+
diff --git a/softcore/makesoftcore.c b/softcore/makesoftcore.c
new file mode 100644
index 000000000000..090e2cddd10c
--- /dev/null
+++ b/softcore/makesoftcore.c
@@ -0,0 +1,244 @@
+/*
+** Ficl softcore generator.
+** Generates both uncompressed and Lempel-Ziv compressed versions.
+** Strips blank lines, strips full-line comments, collapses whitespace.
+** Chops, blends, dices, makes julienne fries.
+**
+** Contributed by Larry Hastings, larry@hastings.org
+**/
+#include <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+
+#include "ficl.h"
+
+
+#ifndef SOFTCORE_OUT
+#define SOFTCORE_OUT "../softcore.c"
+#endif
+
+void fprintDataAsHex(FILE *f, char *data, int length)
+ {
+ int i;
+ while (length)
+ {
+ fprintf(f, "\t");
+ for (i = 0; (i < 8) && length; i++)
+ {
+ char buf[16];
+ /* if you don't do this little stuff, you get ugly sign-extended 0xFFFFFF6b crap. */
+ sprintf(buf, "%08x", (unsigned int)*data++);
+ fprintf(f, "0x%s, ", buf + 6);
+ length--;
+ }
+ fprintf(f, "\n");
+ }
+ }
+
+void fprintDataAsQuotedString(FILE *f, char *data)
+ {
+ int i;
+ int lineIsBlank = 1; /* true */
+
+ while (*data)
+ {
+ if (*data == '\n')
+ {
+ if (!lineIsBlank)
+ fprintf(f, "\\n\"\n");
+ lineIsBlank = 1; /* true */
+ }
+ else
+ {
+ if (lineIsBlank)
+ {
+ fputc('\t', f);
+ fputc('"', f);
+ lineIsBlank = 0; /* false */
+ }
+
+ if (*data == '"')
+ fprintf(f, "\\\"");
+ else if (*data == '\\')
+ fprintf(f, "\\\\");
+ else
+ fputc(*data, f);
+ }
+ data++;
+ }
+ if (!lineIsBlank)
+ fprintf(f, "\"");
+ }
+
+int main(int argc, char *argv[])
+ {
+ char *uncompressed = (char *)malloc(128 * 1024);
+ unsigned char *compressed;
+ char *trace = uncompressed;
+ int i;
+ size_t compressedSize;
+ size_t uncompressedSize;
+ char *src, *dst;
+ FILE *f;
+ time_t currentTimeT;
+ struct tm *currentTime;
+ char cleverTime[32];
+
+ time(&currentTimeT);
+ currentTime = localtime(&currentTimeT);
+ strftime(cleverTime, sizeof(cleverTime), "%Y/%m/%d %H:%M:%S", currentTime);
+
+ *trace++ = ' ';
+
+ for (i = 1; i < argc; i++)
+ {
+ int size;
+ /*
+ ** This ensures there's always whitespace space between files. It *also*
+ ** ensures that src[-1] is always safe in comment detection code below.
+ ** (Any leading whitespace will be thrown away in a later pass.)
+ ** --lch
+ */
+ *trace++ = ' ';
+
+ f = fopen(argv[i], "rb");
+ fseek(f, 0, SEEK_END);
+ size = ftell(f);
+ fseek(f, 0, SEEK_SET);
+ fread(trace, 1, size, f);
+ fclose(f);
+ trace += size;
+ }
+ *trace = 0;
+
+#define IS_EOL(x) ((*x == '\n') || (*x == '\r'))
+#define IS_EOL_COMMENT(x) (((x[0] == '\\') && isspace(x[1])) || ((x[0] == '/') && (x[1] == '/') && isspace(x[2])))
+#define IS_BLOCK_COMMENT(x) ((x[0] == '(') && isspace(x[1]) && isspace(x[-1]))
+
+ src = dst = uncompressed;
+ while (*src)
+ {
+ /* ignore leading whitespace, or entirely blank lines */
+ while (isspace(*src))
+ src++;
+ /* if the line is commented out */
+ if (IS_EOL_COMMENT(src))
+ {
+ /* throw away this entire line */
+ while (*src && !IS_EOL(src))
+ src++;
+ continue;
+ }
+ /*
+ ** This is where we'd throw away mid-line comments, but
+ ** that's simply unsafe. Things like
+ ** start-prefixes
+ ** : \ postpone \ ;
+ ** : ( postpone ( ;
+ ** get broken that way.
+ ** --lch
+ */
+ while (*src && !IS_EOL(src))
+ {
+ *dst++ = *src++;
+ }
+
+ /* strip trailing whitespace */
+ dst--;
+ while (isspace(*dst))
+ dst--;
+ dst++;
+
+ /* and end the line */
+ *dst++ = '\n';
+ }
+
+ *dst = 0;
+
+ /* now make a second pass to collapse all contiguous whitespace to a single space. */
+ src = dst = uncompressed;
+ while (*src)
+ {
+ *dst++ = *src;
+ if (!isspace(*src))
+ src++;
+ else
+ {
+ while (isspace(*src))
+ src++;
+ }
+ }
+ *dst = 0;
+
+ f = fopen(SOFTCORE_OUT, "wt");
+ if (f == NULL)
+ {
+ printf("couldn't open " SOFTCORE_OUT " for writing! giving up.\n");
+ exit(-1);
+ }
+
+ fprintf(f,
+"/*\n"
+"** Ficl softcore\n"
+"** both uncompressed and Lempel-Ziv compressed versions.\n"
+"**\n"
+"** Generated %s\n"
+"**/\n"
+"\n"
+"#include \"ficl.h\"\n"
+"\n"
+"\n",
+ cleverTime);
+
+ uncompressedSize = dst - uncompressed;
+ ficlLzCompress(uncompressed, uncompressedSize, &compressed, &compressedSize);
+
+ fprintf(f, "static size_t ficlSoftcoreUncompressedSize = %d; /* not including trailing null */\n", uncompressedSize);
+ fprintf(f, "\n");
+ fprintf(f, "#if !FICL_WANT_LZ_SOFTCORE\n");
+ fprintf(f, "\n");
+ fprintf(f, "static char ficlSoftcoreUncompressed[] =\n");
+ fprintDataAsQuotedString(f, uncompressed);
+ fprintf(f, ";\n");
+ fprintf(f, "\n");
+ fprintf(f, "#else /* !FICL_WANT_LZ_SOFTCORE */\n");
+ fprintf(f, "\n");
+ fprintf(f, "static unsigned char ficlSoftcoreCompressed[%d] = {\n", compressedSize);
+ fprintDataAsHex(f, compressed, compressedSize);
+ fprintf(f, "\t};\n");
+ fprintf(f, "\n");
+ fprintf(f, "#endif /* !FICL_WANT_LZ_SOFTCORE */\n");
+ fprintf(f,
+"\n"
+"\n"
+"void ficlSystemCompileSoftCore(ficlSystem *system)\n"
+"{\n"
+" ficlVm *vm = system->vmList;\n"
+" int returnValue;\n"
+" ficlCell oldSourceID = vm->sourceId;\n"
+" ficlString s;\n"
+"#if FICL_WANT_LZ_SOFTCORE\n"
+" char *ficlSoftcoreUncompressed = NULL;\n"
+" size_t gotUncompressedSize = 0;\n"
+" returnValue = ficlLzUncompress(ficlSoftcoreCompressed, (unsigned char **)&ficlSoftcoreUncompressed, &gotUncompressedSize);\n"
+" FICL_VM_ASSERT(vm, returnValue == 0);\n"
+" FICL_VM_ASSERT(vm, gotUncompressedSize == ficlSoftcoreUncompressedSize);\n"
+"#endif /* FICL_WANT_LZ_SOFTCORE */\n"
+" vm->sourceId.i = -1;\n"
+" FICL_STRING_SET_POINTER(s, (char *)(ficlSoftcoreUncompressed));\n"
+" FICL_STRING_SET_LENGTH(s, ficlSoftcoreUncompressedSize);\n"
+" returnValue = ficlVmExecuteString(vm, s);\n"
+" vm->sourceId = oldSourceID;\n"
+"#if FICL_WANT_LZ_SOFTCORE\n"
+" free(ficlSoftcoreUncompressed);\n"
+"#endif /* FICL_WANT_LZ_SOFTCORE */\n"
+" FICL_VM_ASSERT(vm, returnValue != FICL_VM_STATUS_ERROR_EXIT);\n"
+" return;\n"
+"}\n"
+"\n"
+"/* end-of-file */\n"
+ );
+ free(uncompressed);
+ free(compressed);
+ }
diff --git a/softcore/marker.fr b/softcore/marker.fr
new file mode 100644
index 000000000000..440732893fda
--- /dev/null
+++ b/softcore/marker.fr
@@ -0,0 +1,25 @@
+\ ** 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/softcore/oo.fr b/softcore/oo.fr
new file mode 100644
index 000000000000..fcb801d7de26
--- /dev/null
+++ b/softcore/oo.fr
@@ -0,0 +1,700 @@
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** 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 an 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
+;
+
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+\ 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.
+
+S" FICL_WANT_FLOAT" ENVIRONMENT? drop [if]
+: 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] \ FICL_WANT_FLOAT
+[endif] \ FICL_WANT_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
+[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
+ 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
+
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+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 @ ;
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+: 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
+[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
+ 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 ;
+
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+\ 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
+[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
+ 0 , \ .vtCount
+[endif]
+ 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/softcore/prefix.fr b/softcore/prefix.fr
new file mode 100644
index 000000000000..3c368d66ea75
--- /dev/null
+++ b/softcore/prefix.fr
@@ -0,0 +1,47 @@
+\ **
+\ ** 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 ;
+
+start-prefixes
+
+S" FICL_WANT_EXTENDED_PREFIX" ENVIRONMENT? drop [if]
+
+\ 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
+: \ postpone \ ; immediate
+: // 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
+\ **
+\ ** __tempbase is precompiled, see prefix.c
+
+: 0b 2 __tempbase ; immediate
+: 0o 8 __tempbase ; immediate
+
+[endif]
+
+: 0d 10 __tempbase ; immediate
+: 0x 16 __tempbase ; immediate
+
+end-prefixes
+
diff --git a/softcore/softcore.fr b/softcore/softcore.fr
new file mode 100644
index 000000000000..6cce6589a831
--- /dev/null
+++ b/softcore/softcore.fr
@@ -0,0 +1,152 @@
+\ ** ficl/softwords/softcore.fr
+\ ** FICL soft extensions
+\ ** John Sadler (john_sadler@alum.mit.edu)
+\ ** September, 1998
+
+
+\ ** 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< ;
+
+
+
+\ ** 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-simple cr ;
+
+
+previous \ lose hidden words from search order
+
+\ ** E N D S O F T C O R E . F R
+
diff --git a/softcore/string.fr b/softcore/string.fr
new file mode 100644
index 000000000000..795b8ce38d0a
--- /dev/null
+++ b/softcore/string.fr
@@ -0,0 +1,149 @@
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** 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/softcore/win32.fr b/softcore/win32.fr
new file mode 100644
index 000000000000..eb0f627e19a5
--- /dev/null
+++ b/softcore/win32.fr
@@ -0,0 +1,211 @@
+\ **
+\ ** win32.fr
+\ ** submitted by Larry Hastings, larry@hastings.org
+\ **
+
+
+S" FICL_PLATFORM_OS" ENVIRONMENT? drop S" WIN32" compare-insensitive 0= [if]
+
+
+: GetProcAddress ( name-addr name-u hmodule -- address )
+ 3 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 2 \ cstringArgumentBitfield
+ (get-proc-address) \ functionAddress
+ [
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+: LoadLibrary ( name-addr name-u -- hmodule )
+ 2 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 1 \ cstringArgumentBitfield
+ [
+ S" LoadLibraryA" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+: FreeLibrary ( hmodule -- success )
+ 1 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ [
+ S" FreeLibrary" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+: DebugBreak ( -- )
+ 0 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ [
+ S" DebugBreak" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-void or literal \ flags
+ ]
+ multicall ;
+
+: OutputDebugString ( addr u -- )
+ 2 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 1 \ cstringArgumentBitfield
+ [
+ S" OutputDebugStringA" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-void or literal \ flags
+ ]
+ multicall ;
+
+: GetTickCount ( -- ticks )
+ 0 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ [
+ S" GetTickCount" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+S" user32.dll" LoadLibrary constant user32.dll
+
+: MessageBox ( flags title-addr title-u body-addr body-u hwnd -- button )
+ 6 \ argumentCount
+ 0 \ floatArgumentBitfield
+ [
+ 2 8 or literal \ cstringArgumentBitfield
+ S" MessageBoxA" user32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+\ Constants for use with MessageBox
+\ the ID* names are possible return values.
+
+0x00000000 constant MB_OK
+0x00000001 constant MB_OKCANCEL
+0x00000002 constant MB_ABORTRETRYIGNORE
+0x00000003 constant MB_YESNOCANCEL
+0x00000004 constant MB_YESNO
+0x00000005 constant MB_RETRYCANCEL
+0x00000010 constant MB_ICONHAND
+0x00000020 constant MB_ICONQUESTION
+0x00000030 constant MB_ICONEXCLAMATION
+0x00000040 constant MB_ICONASTERISK
+0x00000080 constant MB_USERICON
+0x00000000 constant MB_DEFBUTTON1
+0x00000100 constant MB_DEFBUTTON2
+0x00000200 constant MB_DEFBUTTON3
+0x00000300 constant MB_DEFBUTTON4
+0x00000000 constant MB_APPLMODAL
+0x00001000 constant MB_SYSTEMMODAL
+0x00002000 constant MB_TASKMODAL
+0x00004000 constant MB_HELP
+0x00008000 constant MB_NOFOCUS
+0x00010000 constant MB_SETFOREGROUND
+0x00020000 constant MB_DEFAULT_DESKTOP_ONLY
+0x00040000 constant MB_TOPMOST
+0x00080000 constant MB_RIGHT
+0x00100000 constant MB_RTLREADING
+
+MB_ICONEXCLAMATION constant MB_ICONWARNING
+MB_ICONHAND constant MB_ICONERROR
+MB_ICONASTERISK constant MB_ICONINFORMATION
+MB_ICONHAND constant MB_ICONSTOP
+
+
+0x00200000 constant MB_SERVICE_NOTIFICATION
+0x00040000 constant MB_SERVICE_NOTIFICATION
+0x00040000 constant MB_SERVICE_NOTIFICATION_NT3X
+
+0x0000000F constant MB_TYPEMASK
+0x000000F0 constant MB_ICONMASK
+0x00000F00 constant MB_DEFMASK
+0x00003000 constant MB_MODEMASK
+0x0000C000 constant MB_MISCMASK
+
+
+1 constant IDOK
+2 constant IDCANCEL
+3 constant IDABORT
+4 constant IDRETRY
+5 constant IDIGNORE
+6 constant IDYES
+7 constant IDNO
+8 constant IDCLOSE
+9 constant IDHELP
+
+
+\ ** old names
+: output-debug-string OutputDebugString ;
+: debug-break DebugBreak ;
+
+
+: uaddr->cstring { addr u | cstring -- cstring }
+ u 1+ allocate
+ 0= if
+ to cstring
+ addr cstring u move
+ 0 cstring u + c!
+ cstring
+ else
+ 0
+ endif
+ ;
+
+\ **
+\ ** The following four calls:
+\ ** callnativeFunction
+\ ** callcFunction
+\ ** callpascalFunction
+\ ** vcall
+\ ** are deprecated. Please use the more powerful "multicall" instead.
+\ **
+
+\ ** My original native function caller, reimplemented in Ficl using multicall.
+: callnativeFunction { functionAddress popStack -- }
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ functionAddress \ functionAddress
+
+ [
+ multicall-calltype-function
+ multicall-returntype-integer or
+ multicall-reverse-arguments or
+ literal
+ ]
+
+ multicall
+ ;
+
+
+\ ** simple wrappers for callnativeFunction that specify the calling convention
+: callcfunction 1 callnativeFunction ;
+: callpascalfunction 0 callnativeFunction ;
+
+
+\ ** Guy Carver's "vcall" function, reimplemented in Ficl using multicall.
+: vcall { argumentCount index -- }
+ argumentCount 0x80000000 invert or \ cleaned-up argumentCount
+ 0 \ cstringArgumentBitfield
+ 0 \ cstringFlags
+ index \ index
+
+ \ flags:
+ argumentCount 0x80000000 and if multicall-returntype-integer else multicall-returntype-void endif
+
+ [
+ multicall-calltype-virtual-method
+ multicall-reverse-arguments or
+ literal
+ ] or
+
+ multicall
+ ;
+
+[endif]
+
generated by cgit v1.3 (git 2.53.0) at 2026-03-26 14:36:39 +0000