socsvn commit: r287814 - soc2015/clord/head/sys/contrib/ficl
clord at FreeBSD.org
clord at FreeBSD.org
Wed Jul 1 15:15:59 UTC 2015
Author: clord
Date: Wed Jul 1 15:15:58 2015
New Revision: 287814
URL: http://svnweb.FreeBSD.org/socsvn/?view=rev&rev=287814
Log:
Add another file missed in merge process
Added:
soc2015/clord/head/sys/contrib/ficl/softcore.c (props changed)
- copied unchanged from r287813, mirror/FreeBSD/vendor/ficl/dist/softcore.c
Copied: soc2015/clord/head/sys/contrib/ficl/softcore.c (from r287813, mirror/FreeBSD/vendor/ficl/dist/softcore.c)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ soc2015/clord/head/sys/contrib/ficl/softcore.c Wed Jul 1 15:15:58 2015 (r287814, copy of r287813, mirror/FreeBSD/vendor/ficl/dist/softcore.c)
@@ -0,0 +1,2551 @@
+/*
+** Ficl softcore
+** both uncompressed and Lempel-Ziv compressed versions.
+**
+** Generated 2003/05/05 12:42:30
+**/
+
+#include "ficl.h"
+
+
+static size_t ficlSoftcoreUncompressedSize = 25687; /* not including trailing null */
+
+#if !FICL_WANT_LZ_SOFTCORE
+
+static char ficlSoftcoreUncompressed[] =
+ ": empty ( xn..x1 -- ) depth 0 ?do drop loop ;\n"
+ ": cell- ( addr -- addr ) [ 1 cells ] literal - ;\n"
+ ": -rot ( a b c -- c a b ) 2 -roll ;\n"
+ ": abs ( x -- x )\n"
+ "dup 0< if negate endif ;\n"
+ "decimal 32 constant bl\n"
+ ": space ( -- ) bl emit ;\n"
+ ": spaces ( n -- ) 0 ?do space loop ;\n"
+ ": abort\"\n"
+ "state @ if\n"
+ "postpone if\n"
+ "postpone .\"\n"
+ "postpone cr\n"
+ "-2\n"
+ "postpone literal\n"
+ "postpone throw\n"
+ "postpone endif\n"
+ "else\n"
+ "[char] \" parse\n"
+ "rot if\n"
+ "type\n"
+ "cr\n"
+ "-2 throw\n"
+ "else\n"
+ "2drop\n"
+ "endif\n"
+ "endif\n"
+ "; immediate\n"
+ ".( loading CORE EXT words ) cr\n"
+ "0 constant false\n"
+ "false invert constant true\n"
+ ": <> = 0= ;\n"
+ ": 0<> 0= 0= ;\n"
+ ": compile, , ;\n"
+ ": convert char+ 65535 >number drop ; \\ cribbed from DPANS A.6.2.0970\n"
+ ": erase ( addr u -- ) 0 fill ;\n"
+ "variable span\n"
+ ": expect ( c-addr u1 -- ) accept span ! ;\n"
+ ": nip ( y x -- x ) swap drop ;\n"
+ ": tuck ( y x -- x y x) swap over ;\n"
+ ": within ( test low high -- flag ) over - >r - r> u< ;\n"
+ ": ? ( addr -- ) @ . ;\n"
+ ": dump ( addr u -- )\n"
+ "0 ?do\n"
+ "dup c@ . 1+\n"
+ "i 7 and 7 = if cr endif\n"
+ "loop drop\n"
+ ";\n"
+ ".( loading SEARCH & SEARCH-EXT words ) cr\n"
+ ": brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;\n"
+ ": ficl-named-wordlist \\ ( hash-size name -- ) run: ( -- wid )\n"
+ "ficl-wordlist dup create , brand-wordlist does> @ ;\n"
+ ": wordlist ( -- )\n"
+ "1 ficl-wordlist ;\n"
+ ": ficl-set-current ( wid -- old-wid )\n"
+ "get-current swap set-current ;\n"
+ ": do-vocabulary ( -- )\n"
+ "does> @ search> drop >search ;\n"
+ ": ficl-vocabulary ( nBuckets name -- )\n"
+ "ficl-named-wordlist do-vocabulary ;\n"
+ ": vocabulary ( name -- )\n"
+ "1 ficl-vocabulary ;\n"
+ ": previous ( -- ) search> drop ;\n"
+ "1 ficl-named-wordlist hidden\n"
+ ": hide hidden dup >search ficl-set-current ;\n"
+ ": also ( -- )\n"
+ "search> dup >search >search ;\n"
+ ": forth ( -- )\n"
+ "search> drop\n"
+ "forth-wordlist >search ;\n"
+ ": only ( -- )\n"
+ "-1 set-order ;\n"
+ "hide\n"
+ ": list-wid ( wid -- )\n"
+ "dup wid-get-name ( wid c-addr u )\n"
+ "?dup if\n"
+ "type drop\n"
+ "else\n"
+ "drop .\" (unnamed wid) \" x.\n"
+ "endif cr\n"
+ ";\n"
+ "set-current \\ stop hiding words\n"
+ ": order ( -- )\n"
+ ".\" Search:\" cr\n"
+ "get-order 0 ?do 3 spaces list-wid loop cr\n"
+ ".\" Compile: \" get-current list-wid cr\n"
+ ";\n"
+ ": debug ' debug-xt ; immediate\n"
+ ": on-step .\" S: \" .s-simple cr ;\n"
+ "previous \\ lose hidden words from search order\n"
+ "hide\n"
+ ": ?[if] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [if]\" compare-insensitive 0=\n"
+ ";\n"
+ ": ?[else] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [else]\" compare-insensitive 0=\n"
+ ";\n"
+ ": ?[then] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [then]\" compare-insensitive 0= >r\n"
+ "2dup s\" [endif]\" compare-insensitive 0= r>\n"
+ "or\n"
+ ";\n"
+ "set-current\n"
+ ": [else] ( -- )\n"
+ "1 \\ ( level )\n"
+ "begin\n"
+ "begin\n"
+ "parse-word dup while \\ ( level addr len )\n"
+ "?[if] if \\ ( level addr len )\n"
+ "2drop 1+ \\ ( level )\n"
+ "else \\ ( level addr len )\n"
+ "?[else] if \\ ( level addr len )\n"
+ "2drop 1- dup if 1+ endif\n"
+ "else\n"
+ "?[then] if 2drop 1- else 2drop endif\n"
+ "endif\n"
+ "endif ?dup 0= if exit endif \\ level\n"
+ "repeat 2drop \\ level\n"
+ "refill 0= until \\ level\n"
+ "drop\n"
+ "; immediate\n"
+ ": [if] ( flag -- )\n"
+ "0= if postpone [else] then ; immediate\n"
+ ": [then] ( -- ) ; immediate\n"
+ ": [endif] ( -- ) ; immediate\n"
+ "previous\n"
+ "variable save-current\n"
+ ": start-prefixes get-current save-current ! <prefixes> set-current ;\n"
+ ": end-prefixes save-current @ set-current ;\n"
+ ": show-prefixes <prefixes> >search words search> drop ;\n"
+ "start-prefixes\n"
+ "S\" FICL_WANT_EXTENDED_PREFIX\" ENVIRONMENT? drop [if]\n"
+ ": \" postpone s\" ; immediate\n"
+ ": .( postpone .( ; immediate\n"
+ ": \\ postpone \\ ; immediate\n"
+ ": // postpone \\ ; immediate\n"
+ ": 0b 2 __tempbase ; immediate\n"
+ ": 0o 8 __tempbase ; immediate\n"
+ "[endif]\n"
+ ": 0d 10 __tempbase ; immediate\n"
+ ": 0x 16 __tempbase ; immediate\n"
+ "end-prefixes\n"
+ "S\" FICL_WANT_USER\" ENVIRONMENT? drop [if]\n"
+ "variable nUser 0 nUser !\n"
+ ": user \\ name ( -- )\n"
+ "nUser dup @ user 1 swap +! ;\n"
+ "[endif]\n"
+ "S\" FICL_WANT_LOCALS\" ENVIRONMENT? drop [if]\n"
+ ": locals| ( name...name | -- )\n"
+ "begin\n"
+ "bl word count\n"
+ "dup 0= abort\" where's the delimiter??\"\n"
+ "over c@\n"
+ "[char] | - over 1- or\n"
+ "while\n"
+ "(local)\n"
+ "repeat 2drop 0 0 (local)\n"
+ "; immediate\n"
+ ": local ( name -- ) bl word count (local) ; immediate\n"
+ ": 2local ( name -- ) bl word count (2local) ; immediate\n"
+ ": end-locals ( -- ) 0 0 (local) ; immediate\n"
+ ": strdup ( c-addr length -- c-addr2 length2 ior )\n"
+ "0 locals| addr2 length c-addr | end-locals\n"
+ "length 1 + allocate\n"
+ "0= if\n"
+ "to addr2\n"
+ "c-addr addr2 length move\n"
+ "addr2 length 0\n"
+ "else\n"
+ "0 -1\n"
+ "endif\n"
+ ";\n"
+ ": strcat ( 2:a 2:b -- 2:new-a )\n"
+ "0 locals| b-length b-u b-addr a-u a-addr | end-locals\n"
+ "b-u to b-length\n"
+ "b-addr a-addr a-u + b-length move\n"
+ "a-addr a-u b-length +\n"
+ ";\n"
+ ": strcpy ( 2:a 2:b -- 2:new-a )\n"
+ "locals| b-u b-addr a-u a-addr | end-locals\n"
+ "a-addr 0 b-addr b-u strcat\n"
+ ";\n"
+ "[endif]\n"
+ "S\" FICL_WANT_LOCALS\" ENVIRONMENT? drop [if]\n"
+ ".( loading Johns-Hopkins locals ) cr\n"
+ "hide\n"
+ ": compiled-zero ficlInstruction0 , ;\n"
+ ": compiled-float-zero ficlInstructionF0 , ;\n"
+ ": ?-- ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" --\" compare 0= ;\n"
+ ": ?} ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" }\" compare 0= ;\n"
+ ": ?| ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" |\" compare 0= ;\n"
+ "1 constant local-is-double\n"
+ "2 constant local-is-float\n"
+ ": parse-local-prefix-flags ( c-addr u -- c-addr u flags )\n"
+ "0 0 0 locals| stop-loop colon-offset flags u c-addr |\n"
+ "c-addr c@ [char] : =\n"
+ "if\n"
+ "over over 0 exit\n"
+ "endif\n"
+ "u 0 do\n"
+ "c-addr i + c@\n"
+ "case\n"
+ "[char] 1 of flags local-is-double invert and to flags endof\n"
+ "[char] 2 of flags local-is-double or to flags endof\n"
+ "[char] d of flags local-is-double or to flags endof\n"
+ "[char] f of flags local-is-float or to flags endof\n"
+ "[char] i of flags local-is-float invert and to flags endof\n"
+ "[char] s of flags local-is-double invert and to flags endof\n"
+ "[char] : of i 1+ to colon-offset 1 to stop-loop endof\n"
+ "1 to stop-loop\n"
+ "endcase\n"
+ "stop-loop if leave endif\n"
+ "loop\n"
+ "colon-offset 0=\n"
+ "colon-offset u =\n"
+ "or\n"
+ "if\n"
+ "c-addr u 0 exit\n"
+ "endif\n"
+ "c-addr colon-offset +\n"
+ "u colon-offset -\n"
+ "flags\n"
+ ";\n"
+ ": ?delim ( c-addr u -- state | c-addr u 0 )\n"
+ "?| if 2drop 1 exit endif\n"
+ "?-- if 2drop 2 exit endif\n"
+ "?} if 2drop 3 exit endif\n"
+ "dup 0=\n"
+ "if 2drop 4 exit endif\n"
+ "0\n"
+ ";\n"
+ "set-current\n"
+ ": {\n"
+ "0 0 0 locals| flags local-state nLocals |\n"
+ "begin\n"
+ "parse-word ?delim dup to local-state\n"
+ "0= while\n"
+ "nLocals 1+ to nLocals\n"
+ "repeat\n"
+ "nLocals 0 ?do\n"
+ "parse-local-prefix-flags to flags\n"
+ "flags local-is-double and if\n"
+ "flags local-is-float and if (f2local) else (2local) endif\n"
+ "else\n"
+ "flags local-is-float and if (flocal) else (local) endif\n"
+ "endif\n"
+ "loop \\ ( )\n"
+ "local-state 1 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "?delim dup to local-state\n"
+ "0= while\n"
+ "parse-local-prefix-flags to flags\n"
+ "flags local-is-double and if\n"
+ "flags local-is-float and if\n"
+ "compiled-float-zero compiled-float-zero (f2local)\n"
+ "else\n"
+ "compiled-zero compiled-zero (2local)\n"
+ "endif\n"
+ "else\n"
+ "flags local-is-float and if\n"
+ "compiled-float-zero (flocal)\n"
+ "else\n"
+ "compiled-zero (local)\n"
+ "endif\n"
+ "endif\n"
+ "repeat\n"
+ "endif\n"
+ "0 0 (local)\n"
+ "local-state 2 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "?delim dup to local-state\n"
+ "3 < while\n"
+ "local-state 0= if 2drop endif\n"
+ "repeat\n"
+ "endif\n"
+ "local-state 3 <> abort\" syntax error in { } local line\"\n"
+ "; immediate compile-only\n"
+ "previous\n"
+ "[endif]\n"
+ ".( loading MARKER ) cr\n"
+ ": marker ( \"name\" -- )\n"
+ "create\n"
+ "get-current ,\n"
+ "get-order dup ,\n"
+ "0 ?do , loop\n"
+ "does>\n"
+ "0 set-order \\ clear search order\n"
+ "dup body> >name drop\n"
+ "here - allot \\ reset HERE to my xt-addr\n"
+ "dup @ ( pfa current-wid )\n"
+ "dup set-current forget-wid ( pfa )\n"
+ "cell+ dup @ swap ( count count-addr )\n"
+ "over cells + swap ( last-wid-addr count )\n"
+ "0 ?do\n"
+ "dup @ dup ( wid-addr wid wid )\n"
+ ">search forget-wid ( wid-addr )\n"
+ "cell-\n"
+ "loop\n"
+ "drop\n"
+ ";\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl O-O extensions ) cr\n"
+ "17 ficl-vocabulary oop\n"
+ "also oop definitions\n"
+ "user current-class\n"
+ "0 current-class !\n"
+ ": parse-method \\ name run: ( -- c-addr u )\n"
+ "parse-word\n"
+ "postpone sliteral\n"
+ "; compile-only\n"
+ ": (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 }\n"
+ "class name class cell+ @ ( class c-addr u wid )\n"
+ "search-wordlist\n"
+ ";\n"
+ ": lookup-method { class 2:name -- class xt }\n"
+ "class name (lookup-method) ( 0 | xt 1 | xt -1 )\n"
+ "0= if\n"
+ "name type .\" not found in \"\n"
+ "class body> >name type\n"
+ "cr abort\n"
+ "endif\n"
+ ";\n"
+ ": find-method-xt \\ name ( class -- class xt )\n"
+ "parse-word lookup-method\n"
+ ";\n"
+ ": catch-method ( instance class c-addr u -- <method-signature> exc-flag )\n"
+ "lookup-method catch\n"
+ ";\n"
+ ": exec-method ( instance class c-addr u -- <method-signature> )\n"
+ "lookup-method execute\n"
+ ";\n"
+ ": --> ( instance class -- ??? )\n"
+ "state @ 0= if\n"
+ "find-method-xt execute\n"
+ "else\n"
+ "parse-method postpone exec-method\n"
+ "endif\n"
+ "; immediate\n"
+ ": c-> ( instance class -- ?? exc-flag )\n"
+ "state @ 0= if\n"
+ "find-method-xt catch\n"
+ "else\n"
+ "parse-method postpone catch-method\n"
+ "endif\n"
+ "; immediate\n"
+ ": method create does> body> >name lookup-method execute ;\n"
+ "1 ficl-named-wordlist instance-vars\n"
+ "instance-vars dup >search ficl-set-current\n"
+ ": => \\ c:( class meta -- ) run: ( -- ??? ) invokes compiled method\n"
+ "drop find-method-xt compile, drop\n"
+ "; immediate compile-only\n"
+ ": my=> \\ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class\n"
+ "current-class @ dup postpone =>\n"
+ "; immediate compile-only\n"
+ ": my=[ \\ same as my=> , but binds a chain of methods\n"
+ "current-class @\n"
+ "begin\n"
+ "parse-word 2dup ( class c-addr u c-addr u )\n"
+ "s\" ]\" compare while ( class c-addr u )\n"
+ "lookup-method ( class xt )\n"
+ "dup compile, ( class xt )\n"
+ "dup ?object if \\ If object member, get new class. Otherwise assume same class\n"
+ "nip >body cell+ @ ( new-class )\n"
+ "else\n"
+ "drop ( class )\n"
+ "endif\n"
+ "repeat 2drop drop\n"
+ "; immediate compile-only\n"
+ ": do-instance-var\n"
+ "does> ( instance class addr[offset] -- addr[field] )\n"
+ "nip @ +\n"
+ ";\n"
+ ": addr-units: ( offset size \"name\" -- offset' )\n"
+ "create over , +\n"
+ "do-instance-var\n"
+ ";\n"
+ ": chars: \\ ( offset nCells \"name\" -- offset' ) Create n char member.\n"
+ "chars addr-units: ;\n"
+ ": char: \\ ( offset nCells \"name\" -- offset' ) Create 1 char member.\n"
+ "1 chars: ;\n"
+ ": cells: ( offset nCells \"name\" -- offset' )\n"
+ "cells >r aligned r> addr-units:\n"
+ ";\n"
+ ": cell: ( offset nCells \"name\" -- offset' )\n"
+ "1 cells: ;\n"
+ ": do-aggregate\n"
+ "objectify\n"
+ "does> ( instance class pfa -- a-instance a-class )\n"
+ "2@ ( inst class a-class a-offset )\n"
+ "2swap drop ( a-class a-offset inst )\n"
+ "+ swap ( a-inst a-class )\n"
+ ";\n"
+ ": obj: { offset class meta -- offset' } \\ \"name\"\n"
+ "create offset , class ,\n"
+ "class meta --> get-size offset +\n"
+ "do-aggregate\n"
+ ";\n"
+ ": array: ( offset n class meta \"name\" -- offset' )\n"
+ "locals| meta class nobjs offset |\n"
+ "create offset , class ,\n"
+ "class meta --> get-size nobjs * offset +\n"
+ "do-aggregate\n"
+ ";\n"
+ ": ref: ( offset class meta \"name\" -- offset' )\n"
+ "locals| meta class offset |\n"
+ "create offset , class ,\n"
+ "offset cell+\n"
+ "does> ( inst class pfa -- ptr-inst ptr-class )\n"
+ "2@ ( inst class ptr-class ptr-offset )\n"
+ "2swap drop + @ swap\n"
+ ";\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": vcall: ( paramcnt \"name\" -- )\n"
+ "current-class @ 8 + dup @ dup 1+ rot ! \\ Kludge fix to get to .vtCount before it's defined.\n"
+ "create , , \\ ( paramcnt index -- )\n"
+ "does> \\ ( inst class pfa -- ptr-inst ptr-class )\n"
+ "nip 2@ vcall \\ ( params offset inst class offset -- )\n"
+ ";\n"
+ ": vcallr: 0x80000000 or vcall: ; \\ Call with return address desired.\n"
+ "S\" FICL_WANT_FLOAT\" ENVIRONMENT? drop [if]\n"
+ ": vcallf: \\ ( paramcnt -<name>- f: r )\n"
+ "0x80000000 or\n"
+ "current-class @ 8 + dup @ dup 1+ rot ! \\ Kludge fix to get to .vtCount before it's defined.\n"
+ "create , , \\ ( paramcnt index -- )\n"
+ "does> \\ ( inst class pfa -- ptr-inst ptr-class )\n"
+ "nip 2@ vcall f> \\ ( params offset inst class offset -- f: r )\n"
+ ";\n"
+ "[endif] \\ FICL_WANT_FLOAT\n"
+ "[endif] \\ FICL_WANT_VCALL\n"
+ ": end-class ( old-wid addr[size] size -- )\n"
+ "swap ! set-current\n"
+ "search> drop \\ pop struct builder wordlist\n"
+ ";\n"
+ ": suspend-class ( old-wid addr[size] size -- ) end-class ;\n"
+ "set-current previous\n"
+ ": do-do-instance ( -- )\n"
+ "s\" : .do-instance does> [ current-class @ ] literal ;\"\n"
+ "evaluate\n"
+ ";\n"
+ ":noname\n"
+ "wordlist\n"
+ "create\n"
+ "immediate\n"
+ "0 , \\ NULL parent class\n"
+ "dup , \\ wid\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "4 cells , \\ instance size\n"
+ "[else]\n"
+ "3 cells , \\ instance size\n"
+ "[endif]\n"
+ "ficl-set-current\n"
+ "does> dup\n"
+ "; execute metaclass\n"
+ "metaclass drop cell+ @ brand-wordlist\n"
+ "metaclass drop current-class !\n"
+ "do-do-instance\n"
+ "instance-vars >search\n"
+ "create .super ( class metaclass -- parent-class )\n"
+ "0 cells , do-instance-var\n"
+ "create .wid ( class metaclass -- wid ) \\ return wid of class\n"
+ "1 cells , do-instance-var\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ "create .vtCount \\ Number of VTABLE methods, if any\n"
+ "2 cells , do-instance-var\n"
+ "create .size ( class metaclass -- size ) \\ return class's payload size\n"
+ "3 cells , do-instance-var\n"
+ "[else]\n"
+ "create .size ( class metaclass -- size ) \\ return class's payload size\n"
+ "2 cells , do-instance-var\n"
+ "[endif]\n"
+ ": get-size metaclass => .size @ ;\n"
+ ": get-wid metaclass => .wid @ ;\n"
+ ": get-super metaclass => .super @ ;\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": get-vtCount metaclass => .vtCount @ ;\n"
+ ": get-vtAdd metaclass => .vtCount ;\n"
+ "[endif]\n"
+ ": instance ( class metaclass \"name\" -- instance class )\n"
+ "locals| meta parent |\n"
+ "create\n"
+ "here parent --> .do-instance \\ ( inst class )\n"
+ "parent meta metaclass => get-size\n"
+ "allot \\ allocate payload space\n"
+ ";\n"
+ ": array ( n class metaclass \"name\" -- n instance class )\n"
+ "locals| meta parent nobj |\n"
+ "create nobj\n"
+ "here parent --> .do-instance \\ ( nobj inst class )\n"
+ "parent meta metaclass => get-size\n"
+ "nobj * allot \\ allocate payload space\n"
+ ";\n"
+ ": new \\ ( class metaclass \"name\" -- )\n"
+ "metaclass => instance --> init\n"
+ ";\n"
+ ": new-array ( n class metaclass \"name\" -- )\n"
+ "metaclass => array\n"
+ "--> array-init\n"
+ ";\n"
+ ": alloc \\ ( class metaclass -- instance class )\n"
+ "locals| meta class |\n"
+ "class meta metaclass => get-size allocate ( -- addr fail-flag )\n"
+ "abort\" allocate failed \" ( -- addr )\n"
+ "class 2dup --> init\n"
+ ";\n"
+ ": alloc-array \\ ( n class metaclass -- instance class )\n"
+ "locals| meta class nobj |\n"
+ "class meta metaclass => get-size\n"
+ "nobj * allocate ( -- addr fail-flag )\n"
+ "abort\" allocate failed \" ( -- addr )\n"
+ "nobj over class --> array-init\n"
+ "class\n"
+ ";\n"
+ ": allot { 2:this -- 2:instance }\n"
+ "here ( instance-address )\n"
+ "this my=> get-size allot\n"
+ "this drop 2dup --> init\n"
+ ";\n"
+ ": allot-array { nobj 2:this -- 2:instance }\n"
+ "here ( instance-address )\n"
+ "this my=> get-size nobj * allot\n"
+ "this drop 2dup ( 2instance 2instance )\n"
+ "nobj -rot --> array-init\n"
+ ";\n"
+ ": ref ( instance-addr class metaclass \"name\" -- )\n"
+ "drop create , ,\n"
+ "does> 2@\n"
+ ";\n"
+ ": resume-class { 2:this -- old-wid addr[size] size }\n"
+ "this --> .wid @ ficl-set-current ( old-wid )\n"
+ "this --> .size dup @ ( old-wid addr[size] size )\n"
+ "instance-vars >search\n"
+ ";\n"
+ ": sub ( class metaclass \"name\" -- old-wid addr[size] size )\n"
+ "wordlist\n"
+ "locals| wid meta parent |\n"
+ "parent meta metaclass => get-wid\n"
+ "wid wid-set-super \\ set superclass\n"
+ "create immediate \\ get the subclass name\n"
+ "wid brand-wordlist \\ label the subclass wordlist\n"
+ "here current-class ! \\ prep for do-do-instance\n"
+ "parent , \\ save parent class\n"
+ "wid , \\ save wid\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "parent meta --> get-vtCount ,\n"
+ "[endif]\n"
+ "here parent meta --> get-size dup , ( addr[size] size )\n"
+ "metaclass => .do-instance\n"
+ "wid ficl-set-current -rot\n"
+ "do-do-instance\n"
+ "instance-vars >search \\ push struct builder wordlist\n"
+ ";\n"
+ ": offset-of ( class metaclass \"name\" -- offset )\n"
+ "drop find-method-xt nip >body @ ;\n"
+ ": id ( class metaclass -- c-addr u )\n"
+ "drop body> >name ;\n"
+ ": methods \\ ( class meta -- )\n"
+ "locals| meta class |\n"
+ "begin\n"
+ "class body> >name type .\" methods:\" cr\n"
+ "class meta --> get-wid >search words cr previous\n"
+ "class meta metaclass => get-super\n"
+ "dup to class\n"
+ "0= until cr\n"
+ ";\n"
+ ": pedigree ( class meta -- )\n"
+ "locals| meta class |\n"
+ "begin\n"
+ "class body> >name type space\n"
+ "class meta metaclass => get-super\n"
+ "dup to class\n"
+ "0= until cr\n"
+ ";\n"
+ ": see ( class meta -- )\n"
+ "metaclass => get-wid >search see previous ;\n"
+ ": debug ( class meta -- )\n"
+ "find-method-xt debug-xt ;\n"
+ "previous set-current\n"
+ "metaclass drop\n"
+ "constant meta\n"
+ ": subclass --> sub ;\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": hasvtable 4 + ; immediate\n"
+ "[endif]\n"
+ ":noname\n"
+ "wordlist\n"
+ "create immediate\n"
+ "0 , \\ NULL parent class\n"
+ "dup , \\ wid\n"
+ "0 , \\ instance size\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "0 , \\ .vtCount\n"
+ "[endif]\n"
+ "ficl-set-current\n"
+ "does> meta\n"
+ "; execute object\n"
+ "object drop cell+ @ brand-wordlist\n"
+ "object drop current-class !\n"
+ "do-do-instance\n"
+ "instance-vars >search\n"
+ ": class ( instance class -- class metaclass )\n"
+ "nip meta ;\n"
+ ": init ( instance class -- )\n"
+ "meta\n"
+ "metaclass => get-size ( inst size )\n"
+ "erase ;\n"
+ ": array-init ( nobj inst class -- )\n"
+ "0 dup locals| &init &next class inst |\n"
+ "class s\" init\" lookup-method to &init\n"
+ "s\" next\" lookup-method to &next\n"
+ "drop\n"
+ "0 ?do\n"
+ "inst class 2dup\n"
+ "&init execute\n"
+ "&next execute drop to inst\n"
+ "loop\n"
+ ";\n"
+ ": free \\ ( instance class -- )\n"
+ "drop free\n"
+ "abort\" free failed \"\n"
+ ";\n"
+ ": super ( instance class -- instance parent-class )\n"
+ "meta metaclass => get-super ;\n"
+ ": pedigree ( instance class -- )\n"
+ "object => class\n"
+ "metaclass => pedigree ;\n"
+ ": size ( instance class -- sizeof-instance )\n"
+ "object => class\n"
+ "metaclass => get-size ;\n"
+ ": methods ( instance class -- )\n"
+ "object => class\n"
+ "metaclass => methods ;\n"
+ ": index ( n instance class -- instance[n] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size * ( n*size )\n"
+ "inst + class ;\n"
+ ": next ( instance[n] class -- instance[n+1] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size\n"
+ "inst +\n"
+ "class ;\n"
+ ": prev ( instance[n] class -- instance[n-1] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size\n"
+ "inst swap -\n"
+ "class ;\n"
+ ": debug ( 2this -- ?? )\n"
+ "find-method-xt debug-xt ;\n"
+ "previous set-current\n"
+ "only definitions\n"
+ ": oo only also oop definitions ;\n"
+ "[endif]\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl utility classes ) cr\n"
+ "also oop definitions\n"
+ "object subclass c-ref\n"
+ "cell: .class\n"
+ "cell: .instance\n"
+ ": get ( inst class -- refinst refclass )\n"
+ "drop 2@ ;\n"
+ ": set ( refinst refclass inst class -- )\n"
+ "drop 2! ;\n"
+ "end-class\n"
+ "object subclass c-byte\n"
+ "char: .payload\n"
+ ": get drop c@ ;\n"
+ ": set drop c! ;\n"
+ "end-class\n"
+ "object subclass c-2byte\n"
+ "2 chars: .payload\n"
+ ": get drop w@ ;\n"
+ ": set drop w! ;\n"
+ "end-class\n"
+ "object subclass c-4byte\n"
+ "4 chars: .payload\n"
+ ": get drop q@ ;\n"
+ ": set drop q! ;\n"
+ "end-class\n"
+ "object subclass c-cell\n"
+ "cell: .payload\n"
+ ": get drop @ ;\n"
+ ": set drop ! ;\n"
+ "end-class\n"
+ "object subclass c-ptr\n"
+ "c-cell obj: .addr\n"
+ ": get-ptr ( inst class -- addr )\n"
+ "c-ptr => .addr\n"
+ "c-cell => get\n"
+ ";\n"
+ ": set-ptr ( addr inst class -- )\n"
+ "c-ptr => .addr\n"
+ "c-cell => set\n"
+ ";\n"
+ ": clr-ptr\n"
+ "0 -rot c-ptr => .addr c-cell => set\n"
+ ";\n"
+ ": ?null ( inst class -- flag )\n"
+ "c-ptr => get-ptr 0=\n"
+ ";\n"
+ ": inc-ptr ( inst class -- )\n"
+ "2dup 2dup ( i c i c i c )\n"
+ "c-ptr => get-ptr -rot ( i c addr i c )\n"
+ "--> @size + -rot ( addr' i c )\n"
+ "c-ptr => set-ptr\n"
+ ";\n"
+ ": dec-ptr ( inst class -- )\n"
+ "2dup 2dup ( i c i c i c )\n"
+ "c-ptr => get-ptr -rot ( i c addr i c )\n"
+ "--> @size - -rot ( addr' i c )\n"
+ "c-ptr => set-ptr\n"
+ ";\n"
+ ": index-ptr { index 2:this -- }\n"
+ "this --> get-ptr ( addr )\n"
+ "this --> @size index * + ( addr' )\n"
+ "this --> set-ptr\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-cellPtr\n"
+ ": @size 2drop 1 cells ;\n"
+ ": get ( inst class -- cell )\n"
+ "c-ptr => get-ptr @\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr !\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-4bytePtr\n"
+ ": @size 2drop 4 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr q@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr q!\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-2bytePtr\n"
+ ": @size 2drop 2 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr w@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr w!\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-bytePtr\n"
+ ": @size 2drop 1 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr c@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr c!\n"
+ ";\n"
+ "end-class\n"
+ "previous definitions\n"
+ "[endif]\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl string class ) cr\n"
+ "also oop definitions\n"
+ "object subclass c-string\n"
+ "c-cell obj: .count\n"
+ "c-cell obj: .buflen\n"
+ "c-ptr obj: .buf\n"
+ "32 constant min-buf\n"
+ ": get-count ( 2:this -- count ) my=[ .count get ] ;\n"
+ ": set-count ( count 2:this -- ) my=[ .count set ] ;\n"
+ ": ?empty ( 2:this -- flag ) --> get-count 0= ;\n"
+ ": get-buflen ( 2:this -- len ) my=[ .buflen get ] ;\n"
+ ": set-buflen ( len 2:this -- ) my=[ .buflen set ] ;\n"
+ ": get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ;\n"
+ ": set-buf { ptr len 2:this -- }\n"
+ "ptr this my=[ .buf set-ptr ]\n"
+ "len this my=> set-buflen\n"
+ ";\n"
+ ": clr-buf ( 2:this -- )\n"
+ "0 0 2over my=> set-buf\n"
+ "0 -rot my=> set-count\n"
+ ";\n"
+ ": free-buf { 2:this -- }\n"
+ "this my=> get-buf\n"
+ "?dup if\n"
+ "free\n"
+ "abort\" c-string free failed\"\n"
+ "this my=> clr-buf\n"
+ "endif\n"
+ ";\n"
+ ": size-buf { size 2:this -- }\n"
+ "size 0< abort\" need positive size for size-buf\"\n"
+ "size 0= if\n"
+ "this --> free-buf exit\n"
+ "endif\n"
+ "my=> min-buf size over / 1+ * chars to size\n"
+ "this --> get-buflen 0=\n"
+ "if\n"
+ "size allocate\n"
+ "abort\" out of memory\"\n"
+ "size this --> set-buf\n"
+ "size this --> set-buflen\n"
+ "exit\n"
+ "endif\n"
+ "size this --> get-buflen > if\n"
+ "this --> get-buf size resize\n"
+ "abort\" out of memory\"\n"
+ "size this --> set-buf\n"
+ "endif\n"
+ ";\n"
+ ": set { c-addr u 2:this -- }\n"
+ "u this --> size-buf\n"
+ "u this --> set-count\n"
+ "c-addr this --> get-buf u move\n"
+ ";\n"
+ ": get { 2:this -- c-addr u }\n"
+ "this --> get-buf\n"
+ "this --> get-count\n"
+ ";\n"
+ ": cat { c-addr u 2:this -- }\n"
+ "this --> get-count u + dup >r\n"
+ "this --> size-buf\n"
+ "c-addr this --> get-buf this --> get-count + u move\n"
+ "r> this --> set-count\n"
+ ";\n"
+ ": type { 2:this -- }\n"
+ "this --> ?empty if .\" (empty) \" exit endif\n"
+ "this --> .buf --> get-ptr\n"
+ "this --> .count --> get\n"
+ "type\n"
+ ";\n"
+ ": compare ( 2string 2:this -- n )\n"
+ "--> get\n"
+ "2swap\n"
+ "--> get\n"
+ "2swap compare\n"
+ ";\n"
+ ": hashcode ( 2:this -- hashcode )\n"
+ "--> get hash\n"
+ ";\n"
+ ": free ( 2:this -- ) 2dup --> free-buf object => free ;\n"
+ "end-class\n"
+ "c-string subclass c-hashstring\n"
+ "c-2byte obj: .hashcode\n"
+ ": set-hashcode { 2:this -- }\n"
+ "this --> super --> hashcode\n"
+ "this --> .hashcode --> set\n"
+ ";\n"
+ ": get-hashcode ( 2:this -- hashcode )\n"
+ "--> .hashcode --> get\n"
+ ";\n"
+ ": set ( c-addr u 2:this -- )\n"
+ "2swap 2over --> super --> set\n"
+ "--> set-hashcode\n"
+ ";\n"
+ ": cat ( c-addr u 2:this -- )\n"
+ "2swap 2over --> super --> cat\n"
+ "--> set-hashcode\n"
+ ";\n"
+ "end-class\n"
+ "previous definitions\n"
+ "[endif]\n"
+ "S\" FICL_PLATFORM_OS\" ENVIRONMENT? drop S\" WIN32\" compare-insensitive 0= [if]\n"
+ ": GetProcAddress ( name-addr name-u hmodule -- address )\n"
+ "3 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "2 \\ cstringArgumentBitfield\n"
+ "(get-proc-address) \\ functionAddress\n"
+ "[\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": LoadLibrary ( name-addr name-u -- hmodule )\n"
+ "2 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "1 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" LoadLibraryA\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": FreeLibrary ( hmodule -- success )\n"
+ "1 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" FreeLibrary\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": DebugBreak ( -- )\n"
+ "0 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" DebugBreak\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-void or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": OutputDebugString ( addr u -- )\n"
+ "2 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "1 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" OutputDebugStringA\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-void or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": GetTickCount ( -- ticks )\n"
+ "0 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" GetTickCount\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ "S\" user32.dll\" LoadLibrary constant user32.dll\n"
+ ": MessageBox ( flags title-addr title-u body-addr body-u hwnd -- button )\n"
+ "6 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "[\n"
+ "2 8 or literal \\ cstringArgumentBitfield\n"
+ "S\" MessageBoxA\" user32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ "0x00000000 constant MB_OK\n"
+ "0x00000001 constant MB_OKCANCEL\n"
+ "0x00000002 constant MB_ABORTRETRYIGNORE\n"
+ "0x00000003 constant MB_YESNOCANCEL\n"
+ "0x00000004 constant MB_YESNO\n"
+ "0x00000005 constant MB_RETRYCANCEL\n"
+ "0x00000010 constant MB_ICONHAND\n"
+ "0x00000020 constant MB_ICONQUESTION\n"
+ "0x00000030 constant MB_ICONEXCLAMATION\n"
+ "0x00000040 constant MB_ICONASTERISK\n"
+ "0x00000080 constant MB_USERICON\n"
+ "0x00000000 constant MB_DEFBUTTON1\n"
+ "0x00000100 constant MB_DEFBUTTON2\n"
+ "0x00000200 constant MB_DEFBUTTON3\n"
+ "0x00000300 constant MB_DEFBUTTON4\n"
+ "0x00000000 constant MB_APPLMODAL\n"
+ "0x00001000 constant MB_SYSTEMMODAL\n"
+ "0x00002000 constant MB_TASKMODAL\n"
+ "0x00004000 constant MB_HELP\n"
+ "0x00008000 constant MB_NOFOCUS\n"
+ "0x00010000 constant MB_SETFOREGROUND\n"
+ "0x00020000 constant MB_DEFAULT_DESKTOP_ONLY\n"
+ "0x00040000 constant MB_TOPMOST\n"
+ "0x00080000 constant MB_RIGHT\n"
+ "0x00100000 constant MB_RTLREADING\n"
+ "MB_ICONEXCLAMATION constant MB_ICONWARNING\n"
+ "MB_ICONHAND constant MB_ICONERROR\n"
+ "MB_ICONASTERISK constant MB_ICONINFORMATION\n"
+ "MB_ICONHAND constant MB_ICONSTOP\n"
+ "0x00200000 constant MB_SERVICE_NOTIFICATION\n"
+ "0x00040000 constant MB_SERVICE_NOTIFICATION\n"
+ "0x00040000 constant MB_SERVICE_NOTIFICATION_NT3X\n"
+ "0x0000000F constant MB_TYPEMASK\n"
+ "0x000000F0 constant MB_ICONMASK\n"
+ "0x00000F00 constant MB_DEFMASK\n"
+ "0x00003000 constant MB_MODEMASK\n"
+ "0x0000C000 constant MB_MISCMASK\n"
+ "1 constant IDOK\n"
+ "2 constant IDCANCEL\n"
+ "3 constant IDABORT\n"
+ "4 constant IDRETRY\n"
+ "5 constant IDIGNORE\n"
+ "6 constant IDYES\n"
+ "7 constant IDNO\n"
+ "8 constant IDCLOSE\n"
+ "9 constant IDHELP\n"
+ ": output-debug-string OutputDebugString ;\n"
+ ": debug-break DebugBreak ;\n"
+ ": uaddr->cstring { addr u | cstring -- cstring }\n"
+ "u 1+ allocate\n"
*** DIFF OUTPUT TRUNCATED AT 1000 LINES ***
More information about the svn-soc-all
mailing list