Date: Wed, 1 Jul 2015 15:15:58 GMT From: clord@FreeBSD.org To: svn-soc-all@FreeBSD.org Subject: socsvn commit: r287814 - soc2015/clord/head/sys/contrib/ficl Message-ID: <201507011515.t61FFwYQ079354@socsvn.freebsd.org>
next in thread | raw e-mail | index | archive | help
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 ***
Want to link to this message? Use this URL: <https://mail-archive.FreeBSD.org/cgi/mid.cgi?201507011515.t61FFwYQ079354>