/*******************************************************************
** 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;
}
syntax highlighted by Code2HTML, v. 0.9.1