( -*-forth-*- ) ( the high-level part of the kernel. check mole.c for more words ) ints 0 trace-inner! 0 trace-outer! forth ( compile to global dictionary ) ints ( use integers for input and math ) ( parsing ) : accept assert-symbol ; : accept assert-float ; : f->i ; ( postpone ) : ' lookup ; : comp' ' xt>ct ; ( get compilation token ) : postpone-comma ( w xt ) swap ( takes 3 cells ) [ ' lit ] literal compile comma comma ; : postpone comp' postpone-comma ; immediate : ['] lookup postpone literal ; immediate : ]L ] postpone literal ; : 2dup postpone over postpone over ; immediate ( control flow ) : for postpone >r here ; immediate : next postpone decrjnz comma postpone rdrop ; immediate : if postpone jz here 0 comma ; immediate : then here swap ! ; immediate : else >r postpone jmp here 0 comma here r> ! ; immediate : again postpone leave ; immediate ( change this and 'begin' so return stack is untouched in loops ) : until ( flag -- ) postpone if postpone rdrop postpone else postpone leave postpone then ; immediate : pass ( compile a tail call : discard current thread before transferring to next word ) ['] passto compile ' compile ; immediate ( utility ) : cell+ [ 1 cells ]L add ; : cell- [ 1 cells ]L sub ; : xt>body [ 2 cells ]L add ; : xt>link [ 3 cells ]L sub ; : not -1 xor ; : neg not 1 add ; ( implementation specific stuff to create new dictionary items the 'link' words take a symbol and compile link and codefield the other ones are parsing words codefields are 2 cells wide. the first cell points to a primitive (indirect threaded ) : comma-cf comma here cell+ comma ; ( codeaddress -- ) ( compile a codefield ) : link-constant ( value symbol -- ) link [ ' doconst @ ]L comma-cf comma ; : constant link-constant ; ( create a constant ) : link-buffer link [ ' dovar @ ]L comma-cf ; ( symbol -- ) : create link-buffer ; ( create a generic data word ) : variable create 0 comma ; ( create an initialized variable ) : enter-comma [ ' enter @ ]L comma-cf ; : link-word link enter-comma ; : :noname here enter-comma ] ; : link-defer link [ ' dodefer @ ]L comma-cf ['] e-undef compile ; : defer link-defer ; : ' xt>body ! ; ( install a dodoes code field first argument = shared code address ) : does-code! ( pfa xt -- ) dup >r cell+ ! ( store pfa to 2nd codefield cell ) [ ' dodoes @ ]L r> ! ; ( store dodoes address 1st cell ) : latestxt-does-code! ( pfa -- ) latestxt does-code! ; : compile-patchable-literal ( -- patch.address ) 0 postpone literal ( compile dummy inline number ) here cell- ; ( load address of inline number ) ( store current ast in variable ) : !here here swap ! ; ( address -- ) : does> compile-patchable-literal ( compile a literal which will be patched with pfa ) postpone latestxt-does-code! ( creating word calls this to install dodoes code field ) postpone leave ( end creating word's code. next cell is does> code = pfa ) !here ( patch the literal ) ; immediate ( create curried words can be done with does> of course but this is for constant args ) : curry ( arg xt -- ) swap : postpone literal postpone passto compile postpone [ ; : public here ; ( mark current dictioanary point. has to be a link ) : lock 0 swap ! ; ( break link. ) ( address register -- 'current array' ) variable a : @a postpone a postpone @ ; immediate : a@ postpone @a postpone @ ; immediate : a! postpone @a postpone ! ; immediate : a> postpone a postpone point.read ; immediate : >a postpone a postpone point.write ; immediate ( set compiler word in link determined by xt [word representing compilation semantics] ) ( the compiler must be of type ) ( xt -- ) : compiler! ( compiler.xt dest.xt -- ) cell- ! ; ints ( compile a numberword defined with def-numberword ) : numberword-compile ( xt -- ) xt>body [ 2 cells ]L add ( get address of xt table ) numbers cells add @ ( get xt to compile using current number system ) compile ; ( create number state dependent words the word 'numbers' returns the number system currently used 0 = float 1 = int the word 'def-numberword' defines a word which will execute or compile one of the words based on the current number state ) : def-numberword ( tx.float tx.int -- ) swap : postpone [ ( compile execution semantics ) postpone numbers ( get current number system ) postpone route-pass ( use as index in jump table ) comma comma ( build jump table ) ['] numberword-compile latestxt compiler! ; ( for the lazy. be careful. it's really a hack ) ' fadd ' add def-numberword + ' fsub ' sub def-numberword - ' fmul ' mul def-numberword * ' fdiv ' div def-numberword / ' .f ' .d def-numberword . ' flt ' lt def-numberword < ' fgt ' gt def-numberword > ' flte ' lte def-numberword <= ' fgte ' gte def-numberword >= ' feq ' eq def-numberword = : [s] postpone literal ; immediate ( literal symbol ) : [i] postpone literal ; immediate ( literal int ) : [f] postpone literal ; immediate ( literal float ) : mark ( mark the dictionary. 'undo point' ) here [s] empty link enter-comma ( create the word 'empty' ) postpone literal ( compile literal link address ) postpone rewind postpone leave ; : port ( port -- address ) 16 add cells base add ; ( fields ) variable field-counter : fields 0 field-counter ! ; : field field-counter @postinc cells postpone literal postpone add ; immediate ( allot management ) : here>r postpone here postpone >r ; immediate : r>here postpone r> postpone free! ; immediate ( some parsing words. ) : load load-module ; : receive bind ; ( load the high level code ) load pd load forth