/*******************************************************************
** s o f t c o r e . c
** Forth Inspired Command Language - 
** Words from CORE set written in FICL
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 27 December 1997
** Last update: Wed May 24 15:16:38 2000
*******************************************************************/
/*
** This file contains definitions that are compiled into the
** system dictionary by the first virtual machine to be created.
** Created automagically by ficl/softwords/softcore.pl 
*/


#include "ficl.h"

static char softWords[] = 
/*
** ficl/softwords/softcore.fr
** FICL soft extensions
** John Sadler (john_sadler@alum.mit.edu)
** September, 1998
** Ficl USER variables
** See words.c for primitive def'n of USER
*/
#if FICL_WANT_USER
    "variable nUser  0 nUser ! "
    ": user "
    "nUser dup @ user 1 swap +! ; "
#endif
/*
** ficl extras
*/
    ": empty depth 0 ?do drop loop ; "
    ": cell-  [ 1 cells ] literal -  ; "
    ": -rot  2 -roll ; "
/*
** CORE 
*/
    ": abs "
    "dup 0< if negate endif ; "
    "decimal 32 constant bl "
    ": space     bl emit ; "
    ": spaces   0 ?do space loop ; "
    ": abort\" "
    "postpone if "
    "postpone .\" "
    "postpone cr "
    "[ -2 ] literal , "
    "postpone throw "
    "postpone endif "
    "; immediate "
/*
** CORE EXT
*/
    "0  constant false "
    "-1 constant true "
    ": <>   = 0= ; "
    ": 0<>  0= 0= ; "
    ": compile,  , ; "
    ": erase    0 fill ; "
    ": nip     swap drop ; "
    ": tuck  swap over ; "
    ": within   over - >r - r>  u<  ; "
/*
** LOCAL EXT word set
*/
#if FICL_WANT_LOCALS
    ": locals| "
    "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  bl word count (local) ;  immediate "
    ": 2local bl word count (2local) ; immediate "
    ": end-locals  0 0 (local) ;  immediate "
#endif
/*
** TOOLS word set...
*/
    ": ?  @ . ; "

    ": .0 >r 0 <# #s #> r> over - 0 max dup "
    "if 0 do [char] 0 emit loop "
    "else drop then type ; "

    ": >prt dup bl u< if drop [char] . then ; "

    ": ptype "
    "0 do dup c@ >prt emit 1+ loop drop ; "

    ": dump dup 0= if 2drop exit then "
    "15 + 16 / 0 do "
    "cr base @ swap 16 base ! dup 4 .0 space "
    "space dup 16 0 "
    "do i 4 mod 0= if space then "
    "dup c@ 2 .0 space 1+ "
    "loop swap 16  ptype "
    "swap base ! loop drop cr ; "

/*
** SEARCH+EXT words and ficl helpers
*/
    ": wordlist "
    "1 ficl-wordlist ; "
    ": do-vocabulary "
    "does>  @ search> drop >search ; "
    ": vocabulary "
    "wordlist create ,  do-vocabulary ; "
    ": ficl-vocabulary "
    "ficl-wordlist create ,  do-vocabulary ; "
    ": also "
    "search> dup >search >search ; "
    ": forth "
    "search> drop "
    "forth-wordlist >search ; "
    ": only "
    "-1 set-order ; "
    ": order "
    ".\" Search: \" "
    "get-order  0 ?do x. loop cr "
    ".\" Compile: \" get-current x. cr  ; "
    ": previous  search> drop ; "
    ": ficl-set-current "
    "get-current swap set-current ; "
    "wordlist constant hidden "
    ": hide   hidden dup >search ficl-set-current ; "
/*
** E N D   S O F T C O R E . F R
*/
#if FICL_WANT_LOCALS
/*
** ficl/softwords/jhlocal.fr
** stack comment style local syntax...
*/
    "hide "
    "0 constant zero "
    ": ?-- "
    "2dup s\" --\" compare 0= ; "
    ": ?} "
    "2dup s\" }\"  compare 0= ; "
    ": ?| "
    "2dup s\" |\"  compare 0= ; "
    ": ?2loc "
    "over c@ [char] 2 = if true else false endif ; "
    ": ?delim "
    "?|  if  2drop 1 exit endif "
    "?-- if  2drop 2 exit endif "
    "?}  if  2drop 3 exit endif "
    "dup 0= "
    "if  2drop 4 exit endif "
    "0 "
    "; "
    "set-current "
    ": { "
    "0 dup locals| locstate | "
    "begin "
    "parse-word "
    "?delim dup to locstate "
    "0= while "
    "rot 1+ "
    "repeat "
    "0 do "
    "?2loc if (2local) else (local) endif "
    "loop "
    "locstate 1 = if "
    "begin "
    "parse-word "
    "?delim dup to locstate "
    "0= while "
    "?2loc if "
    "postpone zero postpone zero  (2local) "
    "else "
    "postpone zero  (local) "
    "endif "
    "repeat "
    "endif "
    "0 0 (local) "
    "locstate 2 = if "
    "begin "
    "parse-word "
    "?delim dup to locstate "
    "0= while "
    "2drop "
    "repeat "
    "endif "
    "locstate 3 <> abort\" syntax error in { } local line\" "
    "; immediate compile-only "
    "previous "
#endif
/*
** ficl/softwords/marker.fr
** Ficl implementation of CORE EXT MARKER
*/
    ": marker "
    "create "
    "get-current , "
    "get-order dup , "
    "0 ?do , loop "
    "does> "
    "0 set-order "
    "dup body> >name drop "
    "here - allot "
    "dup @ "
    "dup set-current forget-wid "
    "cell+ dup @ swap "
    "over cells + swap "
    "0 ?do "
    "dup @ dup "
    ">search forget-wid "
    "cell- "
    "loop "
    "drop "
    "; "
/*
** 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 "
    "7 ficl-vocabulary oop "
    "also oop definitions "
    "user current-class "
    "0 current-class ! "
*/
/*
** L A T E   B I N D I N G
*/
/*
    ": parse-method "
    "parse-word "
    "postpone sliteral "
    "; compile-only "
    ": lookup-method "
    "2dup "
    "local u "
    "local c-addr "
    "end-locals "
    "2 pick cell+ @ "
    "search-wordlist "
    "0= if "
    "c-addr u type .\"  not found in \" "
    "body> >name type "
    "cr abort "
    "endif "
    "; "
    ": exec-method "
    "lookup-method execute "
    "; "
    ": find-method-xt "
    "parse-word lookup-method "
    "; "
    ": --> "
    "state @ 0= if "
    "find-method-xt execute "
    "else "
    "parse-method  postpone exec-method "
    "endif "
    "; immediate "
*/
/*
** E A R L Y   B I N D I N G
*/
/*
    ": => "
    "drop find-method-xt compile, drop "
    "; immediate compile-only "
*/
/*
** I N S T A N C E   V A R I A B L E S
*/
/*
    "wordlist "
    "dup constant instance-vars "
    "dup >search ficl-set-current "
    ": do-instance-var "
    "does> "
    "nip @ + "
    "; "
    ": addr-units: "
    "create over , + "
    "do-instance-var "
    "; "
    ": chars: "
    "chars addr-units: ; "
    ": char: "
    "1 chars: ; "
    ": cells: "
    "cells >r aligned r> addr-units: "
    "; "
    ": cell: "
    "1 cells: ; "
    ": do-aggregate "
    "does> "
    "2@ "
    "2swap drop "
    "+ swap "
    "; "
    ": obj: "
    "locals| meta class offset | "
    "create  offset , class , "
    "class meta --> get-size  offset + "
    "do-aggregate "
    "; "
    ": array: "
    "locals| meta class nobjs offset | "
    "create offset , class , "
    "class meta --> get-size  nobjs * offset + "
    "do-aggregate "
    "; "
    ": ref: "
    "locals| meta class offset | "
    "create offset , class , "
    "offset cell+ "
    "does> "
    "2@ "
    "2swap drop + @ swap "
    "; "
    ": end-class "
    "swap ! set-current "
    "search> drop "
    "; "
    "set-current previous "
    ": do-do-instance "
    "s\" : .do-instance does> [ current-class @ ] literal ;\" "
    "evaluate "
    "; "
*/
/*
** M E T A C L A S S 
*/
/*
    ":noname "
    "wordlist "
    "create "
    "immediate "
    "0       , "
    "dup     , "
    "3 cells , "
    "ficl-set-current "
    "does> dup "
    ";  execute metaclass "
    "metaclass drop current-class ! "
    "do-do-instance "
    "instance-vars >search "
    "create .super "
    "0 cells , do-instance-var "
    "create .wid "
    "1 cells , do-instance-var "
    "create  .size "
    "2 cells , do-instance-var "
    "previous "
    ": get-size    metaclass => .size  @ ; "
    ": get-wid     metaclass => .wid   @ ; "
    ": get-super   metaclass => .super @ ; "
    ": instance "
    "locals| meta parent | "
    "create "
    "here parent --> .do-instance "
    "parent meta metaclass => get-size "
    "allot "
    "; "
    ": array "
    "locals| meta parent nobj | "
    "create  nobj "
    "here parent --> .do-instance "
    "parent meta metaclass => get-size "
    "nobj *  allot "
    "; "
    ": new "
    "metaclass => instance --> init "
    "; "
    ": new-array "
    "metaclass => array "
    "--> array-init "
    "; "
    ": alloc "
    "locals| meta class | "
    "class meta metaclass => get-size allocate "
    "abort\" allocate failed \" "
    "class 2dup --> init "
    "; "
    ": alloc-array "
    "locals| meta class nobj | "
    "class meta metaclass => get-size "
    "nobj * allocate "
    "abort\" allocate failed \" "
    "nobj over class --> array-init "
    "class "
    "; "
    ": ref "
    "drop create , , "
    "does> 2@ "
    "; "
    ": sub "
    "wordlist "
    "locals| wid meta parent | "
    "parent meta metaclass => get-wid "
    "wid wid-set-super "
    "create  immediate "
    "here current-class ! "
    "parent , "
    "wid    , "
    "here parent meta --> get-size dup , "
    "metaclass => .do-instance "
    "wid ficl-set-current -rot "
    "do-do-instance "
    "instance-vars >search "
    "; "
    ": offset-of "
    "drop find-method-xt nip >body @ ; "
    ": id "
    "drop body> >name  ; "
    ": methods "
    "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 "
    "; "
    ": pedigree "
    "locals| meta class | "
    "begin "
    "class body> >name type space "
    "class meta metaclass => get-super "
    "dup to class "
    "0= until  cr "
    "; "
    ": see "
    "metaclass => get-wid >search see previous ; "
    "set-current "
    "metaclass drop "
    "constant meta "
    ": subclass   --> sub ; "
*/
/*
** O B J E C T
*/
/*
    ":noname "
    "wordlist "
    "create  immediate "
    "0       , "
    "dup     , "
    "0       , "
    "ficl-set-current "
    "does> meta "
    ";  execute object "
    "object drop current-class ! "
    "do-do-instance "
    ": class "
    "nip meta ; "
    ": init "
    "meta "
    "metaclass => get-size "
    "erase ; "
    ": array-init "
    "0 dup locals| &init &next class inst | "
    "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 "
    "drop free "
    "abort\" free failed \" "
    "; "
    ": super "
    "meta  metaclass => get-super ; "
    ": pedigree "
    "object => class "
    "metaclass => pedigree ; "
    ": size "
    "object => class "
    "metaclass => get-size ; "
    ": methods "
    "object => class "
    "metaclass => methods ; "
    ": index "
    "locals| class inst | "
    "inst class "
    "object => class "
    "metaclass => get-size  * "
    "inst +  class ; "
    ": next "
    "locals| class inst | "
    "inst class "
    "object => class "
    "metaclass => get-size "
    "inst + "
    "class ; "
    ": prev "
    "locals| class inst | "
    "inst class "
    "object => class "
    "metaclass => get-size "
    "inst swap - "
    "class ; "
    "set-current "
    "previous definitions "
*/
/*
** ficl/softwords/classes.fr
** F I C L   2 . 0   C L A S S E S
*/
/*
    ".( loading ficl utility classes ) cr "
    "also oop definitions "
    "object subclass c-ref "
    "cell: .class "
    "cell: .instance "
    ": get "
    "drop 2@ ; "
    ": set "
    "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 "
    "cell: .payload "
    ": get  drop @ ; "
    ": set  drop ! ; "
    "end-class "
*/
/*
** C - P T R 
*/
/*
    "object subclass c-ptr "
    "c-4byte obj: .addr "
    ": get-ptr "
    "c-ptr   => .addr "
    "c-4byte => get "
    "; "
    ": set-ptr "
    "c-ptr   => .addr "
    "c-4byte => set "
    "; "
    ": clr-ptr "
    "0 -rot  c-ptr => .addr  c-4byte => set "
    "; "
    ": ?null "
    "c-ptr => get-ptr 0= "
    "; "
    ": inc-ptr "
    "2dup 2dup "
    "c-ptr => get-ptr  -rot "
    "--> @size  +  -rot "
    "c-ptr => set-ptr "
    "; "
    ": dec-ptr "
    "2dup 2dup "
    "c-ptr => get-ptr  -rot "
    "--> @size  -  -rot "
    "c-ptr => set-ptr "
    "; "
    ": index-ptr "
    "locals| class inst index | "
    "inst class  c-ptr => get-ptr "
    "inst class --> @size  index *  + "
    "inst class  c-ptr => set-ptr "
    "; "
    "end-class "
*/
/*
** C - C E L L P T R 
*/
/*
    "c-ptr subclass c-cellPtr "
    ": @size   2drop  4  ; "
    ": get "
    "c-ptr => get-ptr @ "
    "; "
    ": set "
    "c-ptr => get-ptr ! "
    "; "
    "end-class "
*/
/*
** C - 2 B Y T E P T R 
*/
/*
    "c-ptr subclass c-2bytePtr "
    ": @size   2drop  2  ; "
    ": get "
    "c-ptr => get-ptr w@ "
    "; "
    ": set "
    "c-ptr => get-ptr w! "
    "; "
    "end-class "
*/
/*
** C - B Y T E P T R 
*/
/*
    "c-ptr subclass c-bytePtr "
    ": @size   2drop  1  ; "
    ": get "
    "c-ptr => get-ptr c@ "
    "; "
    ": set "
    "c-ptr => get-ptr c! "
    "; "
    "end-class "
    "previous definitions "
*/
/*
** ficl/softwords/string.fr
*/
/*
** C - S T R I N G
*/
/*
    ".( loading ficl string class ) cr "
    "also oop definitions "
    "object subclass c-string "
    "c-4byte obj: .count "
    "c-4byte obj: .buflen "
    "c-ptr obj: .buf "
    "64 constant min-buf "
    ": get-count  c-string => .count  c-4byte => get ; "
    ": set-count  c-string => .count  c-4byte => set ; "
    ": ?empty  --> get-count 0= ; "
    ": get-buflen  c-string => .buflen  c-4byte => get ; "
    ": set-buflen  c-string => .buflen  c-4byte => set ; "
    ": get-buf  c-string => .buf  c-ptr => get-ptr ; "
    ": set-buf   { ptr len 2this -- } "
    "ptr 2this c-string => .buf  c-ptr => set-ptr "
    "len 2this c-string => set-buflen "
    "; "
    ": clr-buf "
    "0 0 2over  c-string => set-buf "
    "0 -rot     c-string => set-count "
    "; "
    ": free-buf   { 2this -- } "
    "2this c-string => get-buf "
    "?dup if "
    "free "
    "abort\" c-string free failed\" "
    "2this  c-string => clr-buf "
    "endif "
    "; "
    ": size-buf  { size 2this -- } "
    "size 0< abort\" need positive size for size-buf\" "
    "size 0= if "
    "2this --> free-buf exit "
    "endif "
    "c-string => min-buf size over / 1+ * chars to size "
    "2this --> get-buflen  0= "
    "if "
    "size allocate "
    "abort\" out of memory\" "
    "size 2this --> set-buf "
    "size 2this --> set-buflen "
    "exit "
    "endif "
    "size 2this --> get-buflen > if "
    "2this --> get-buf size resize "
    "abort\" out of memory\" "
    "size 2this --> set-buf "
    "endif "
    "; "
    ": set   { c-addr u 2this -- } "
    "u 2this --> size-buf "
    "u 2this --> set-count "
    "c-addr 2this --> get-buf  u move "
    "; "
    ": get   { 2this -- c-addr u } "
    "2this --> get-buf "
    "2this --> get-count "
    "; "
    ": cat   { c-addr u 2this -- } "
    "2this --> get-count u +  dup >r "
    "2this --> size-buf "
    "c-addr  2this --> get-buf 2this --> get-count +  u move "
    "r> 2this --> set-count "
    "; "
    ": type   { 2this -- } "
    "2this --> ?empty if .\" (empty) \" exit endif "
    "2this --> .buf --> get-ptr "
    "2this --> .count --> get "
    "type "
    "; "
    ": compare "
    "c-string => get "
    "2swap "
    "c-string => get "
    "2swap compare "
    "; "
    ": hashcode "
    "c-string => get  hash "
    "; "
    ": free  2dup c-string => free-buf  object => free ; "
    "end-class "
    "c-string subclass c-hashstring "
    "c-2byte obj: .hashcode "
    ": set-hashcode   { 2this -- } "
    "2this  --> super --> hashcode "
    "2this  --> .hashcode --> set "
    "; "
    ": get-hashcode "
    "--> .hashcode --> get "
    "; "
    ": set "
    "2swap 2over --> super --> set "
    "--> set-hashcode "
    "; "
    ": cat "
    "2swap 2over --> super --> cat "
    "--> set-hashcode "
    "; "
    "end-class "
    "previous definitions "
*/
    "quit ";


void ficlCompileSoftCore(FICL_VM *pVM)
{
    int ret = sizeof (softWords);
    ret = ficlExec(pVM, softWords);
    if (ret == VM_ERREXIT)
        assert(FALSE);
    return;
}