/* * Pure Data Packet - Packet forth kernel * Copyright (c) by Tom Schouten * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. * */ /* pf kernel */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #define D if (0) static int trace_mode = 0; /* Some convenience macros for accessing the vm data in a DEF_FORTHWORD definition */ #define VM_DS vm->data_stack ///< vm data stack (same as s, though writable) #define VM_RS vm->return_stack ///< vm return stack #define VM_IP vm->ip ///< vm instruction pointer #define VM_CURRENT vm->current ///< vm current word // used quite a lot PF_PRIMITIVE(pf_forthword_execute); static pf_error_t atom_error(pf_atom_t *a){ PF_ASSERT(a); if (a->t == a_error) return a->w.w_error; if ((a->t == a_list) && (a->w.w_list->first) && (a->w.w_list->first->t == a_error)) { return a->w.w_list->first->w.w_error; } return 0; } static char *atom_error_msg(pf_atom_t *a){ PF_ASSERT(a); char *msg = 0; if ((a->t == a_list) && (a->w.w_list->first) && (a->w.w_list->first->next) && (a->w.w_list->first->next->t == a_packet)) { msg = pf_packet_string_data(a->w.w_list->first->next->w.w_packet); } return msg; } /*** DICTIONARY ***/ // return the link of witch atom is part // a link is defined by having a sentinel pointing to the owning pf_link_t struct pf_list_t *pf_atom_link(pf_atom_t *a){ if (!a) return 0; while (a->next) a = a->next; // move to end if (a->t != a_forth_sentinel) return 0; // check if it's an end pointer return a->w.w_list; } int pf_list_is_link(pf_list_t *l){ return pf_atom_link(l->last) ? -1 : 0 ; } // ( atompointer -- symbol ) if atom pointer is part of a link, return // name, otherwize return '' symbol static PF_PRIMITIVE(pf_forthword_word_name){ CHECKN(1); pf_atom_t *a = ATOM_POINTER(ARG0); pf_list_t *l = pf_atom_link(a); pf_symbol_t *name = l ? PF_LINK_TO_NAME(l)->w.w_symbol : pf_symbol(""); DROP; PUSH_SYMBOL(name); EXIT; } static pf_list_t *lookup_link(pf_list_t *dictionary, pf_symbol_t *name){ pf_atom_t *a = dictionary->first; while (a){ if (a->t == a_list){ pf_list_t *link = a->w.w_list; if (pf_list_is_link(link) && link->first && (link->first->t == a_symbol) && (link->first->w.w_symbol == name)) return link; } a = a->next; } return 0; } pf_list_t *pf_vm_lookup_link(pf_vm_t *vm, pf_symbol_t *name){ return lookup_link(vm->allot_stack, name); } pf_atom_t *pf_vm_find(pf_vm_t *vm, pf_symbol_t *name){ pf_list_t *link = lookup_link(vm->allot_stack, name); if (link) return PF_LINK_TO_XT(link); return 0; } static pf_list_t *last_link (pf_vm_t *vm){ pf_atom_t *a = vm->allot_stack->first; while (a){ if (a->t == a_list){ pf_list_t *link = a->w.w_list; if (pf_list_is_link(link)) return link; } } return 0; } static pf_atom_t *NAME_TO_XT(pf_vm_t *vm, char *name){ pf_list_t *link = pf_vm_lookup_link(vm, pf_symbol(name)); if (!link) return 0; else return PF_LINK_TO_XT(link); } static void cache_xt(pf_vm_t *vm){ vm->xt_comma = NAME_TO_XT(vm, ","); vm->xt_execute = NAME_TO_XT(vm, "execute"); vm->xt_leave = NAME_TO_XT(vm, "leave"); vm->xt_lit = NAME_TO_XT(vm, "lit"); vm->xt_do_pass = NAME_TO_XT(vm, "do-pass"); } static PF_PRIMITIVE(pf_forthword_cache_xt){ cache_xt(vm); EXIT; } /* comma: all traffic to dictionary has to go through this function a sentinel is used so that 'here' and other forward references will work */ // comma to any link static void comma_to_link(pf_vm_t *vm, pf_list_t *link, pf_atom_t *a){ // make sure that if we compile an xt, it is a valid one PF_ASSERT( (vm->xt_comma == 0) /* for bootstrapping */ || (a->t != a_forth_xt) || (((pf_atom_t *)(a->w.w_pointer))->t == a_forth_codefield)); // make sure the list is a link PF_ASSERT(link->last->t == a_forth_sentinel); PF_ASSERT(link->last->w.w_list == link); // replace sentinel with atom and add new sentinel link->last->t = a->t; link->last->w.w_int = a->w.w_int; a->t = a_forth_sentinel; a->w.w_pointer = link; pf_list_queue_atom(link, a); } // comma to last link void pf_vm_comma_atom(pf_vm_t *vm, pf_atom_t *a){ pf_list_t *link = last_link(vm); comma_to_link(vm, link, a); } void pf_vm_comma(pf_vm_t *vm, pf_word_type_t t, pf_word_t w){ pf_atom_t *a = pf_atom_new(); a->t = t; a->w.w_int = w.w_int; pf_vm_comma_atom(vm, a); } /* create an empty link */ static void add_sentinel(pf_list_t *link){ pf_list_queue(link, a_forth_sentinel, (pf_word_t)(void*)link); // comma needs this } static pf_list_t *empty_link (pf_vm_t *vm, pf_symbol_t *symbol){ pf_list_t *link = pf_list_new(); pf_list_push_symbol(link, symbol); add_sentinel(link); pf_list_push_list(vm->allot_stack, link); return link; } /* this creates a link with standard compilation semantics, and an empty documentation field */ static pf_list_t *create_link (pf_vm_t *vm, pf_symbol_t *symbol){ pf_list_t *link = empty_link(vm, symbol); pf_list_t *doc = pf_list_new(); pf_list_push(doc, a_undef, (pf_word_t)0); // PF_ASSERT(vm->xt_comma); pf_vm_comma(vm, a_forth_xt, (pf_word_t)vm->xt_comma); // DEFAULT CT SEMANTICS pf_vm_comma(vm, a_list, (pf_word_t)doc); // DEFAULT DOCUMENTATION return link; } /* this creates a link with name, compile semantics and codefield */ pf_list_t *pf_vm_add_primitive(pf_vm_t *vm, pf_symbol_t *symbol, pf_forth_primitive_t word) { pf_list_t *link = create_link(vm, symbol); pf_vm_comma(vm, a_forth_codefield, (pf_word_t)(void *)word); return link; } /* mark last word as immediate */ static void immediate(pf_vm_t *vm){ pf_list_t *link = last_link(vm); PF_ASSERT(vm->xt_execute); PF_LINK_TO_COMPILER(link)->w.w_pointer = vm->xt_execute; } static PF_PRIMITIVE(pf_forthword_lit); static PF_PRIMITIVE(pf_forthword_jmp); static PF_PRIMITIVE(pf_forthword_enter); /*** INNER INTERPRETER ***/ /* inner interpreter (next routine) note the asserts are removed and replaced with explicit type checking. maybe a bit slower but makes it more robust. */ static inline void set_current(pf_vm_t *vm, pf_atom_t *current){ // assert hook vm->current = current; } static inline pf_error_t get_next(pf_vm_t *vm){ if (vm->ip && (vm->ip->t == a_forth_xt)){ set_current(vm, vm->ip->w.w_pointer); // set current word pointer vm->ip = vm->ip->next; // advance ip EXIT; } THROW(e_exec, "invalid instruction pointer (null or not a_forth_xt)"); } /* execute the codefield pointed to by vm->current */ static inline pf_error_t execute_current(pf_vm_t *vm){ pf_error_t e; if (vm->current && (vm->current->t == a_forth_codefield)){ pf_list_t *l = PF_XT_TO_LNK(vm->current); // if (l) { pf_post("execute: %s", l->first->w.w_symbol->s_name); } /* execute primitive */ e = vm->current->w.w_primitive(vm->data_stack, vm); //PF_ASSERT(e != e_internal); /* done */ return e; } /* no executable code */ pf_list_push_forth_xt(vm->data_stack, vm->current); THROW(e_inval, "invalid codefield (null or not a_forth_codefield)"); } /* translate signals -> exceptions */ static inline pf_error_t check_signals(pf_vm_t *vm){ int i = -1; switch(i){ case 1: THROW(e_interrupt, "caught ctrl-C"); case 2: THROW(e_interrupt, "floating point exception"); case 4: THROW(e_interrupt, "segmentation violation"); default: THROW(e_interrupt, "multiple interrupts: mask %d", i); } } /* one clock tick */ static inline pf_error_t single_step(pf_vm_t *vm){ pf_error_t e; e = get_next(vm); if (!e) { e = execute_current(vm); } return e; } /* execute ( xt -- ) */ PF_PRIMITIVE(pf_forthword_execute) { CHECKN(1); if (ARG0->t != a_forth_xt){ THROW(e_inval, "execute needs execution token"); } if (ARG0->w.w_pointer == 0){ THROW(e_inval, "null execution token"); } //CHECK1(a_forth_xt); set_current(vm, pf_list_pop(s).w_pointer); return execute_current(vm); } /* multiword primitives: looking at VM_IP */ static PF_PRIMITIVE(pf_forthword_case){ CHECK1(a_int); PF_STACK_CHECK1(VM_RS, a_atom_pointer); int n = ARG0->w.w_int; if (n < 0) return e_inval; while (n--){ PF_ASSERT(VM_IP->next); if (VM_IP->next->t != a_forth_xt) return e_inval; VM_IP = VM_IP->next; } set_current(vm, VM_IP->w.w_atom_pointer); // get xt vm->ip = pf_list_pop(VM_RS).w_atom_pointer; // pop ip DROP1; // drop count return execute_current(vm); // execute } // this should be the only place that sets the IP, and 'LIT' should be // the only thing that reads the IP. static PF_PRIMITIVE(pf_forthword_setip){ PF_STACK_CHECK1(VM_DS, a_atom_pointer); vm->ip = pf_list_pop(s).w_atom_pointer; EXIT; } #define JMP {\ PF_ASSERT(vm->ip);\ vm->ip = vm->ip->w.w_pointer;\ PF_ASSERT(vm->ip);\ EXIT;\ } #define SKIP {vm->ip = vm->ip->next; EXIT;} static int BOOL(pf_atom_t *x){ // everything is true, except... int things_that_are_false = ((x->t == a_undef) || ((x->t == a_int) && (x->w.w_int == 0)) || ((x->t == a_atom_pointer) && (x->w.w_atom_pointer == 0))); return !things_that_are_false; } /* unconditional jmp */ static PF_PRIMITIVE(pf_forthword_jmp) JMP /* jnz */ static PF_PRIMITIVE(pf_forthword_jnz){ PF_ASSERT(vm->ip); CHECKN(1); int condition = BOOL(ARG0); DROP1; if (condition) JMP else SKIP; } /* jz */ static PF_PRIMITIVE(pf_forthword_jz){ PF_ASSERT(vm->ip); CHECKN(1); int condition = BOOL(ARG0); DROP1; if (!condition) JMP else SKIP; } static PF_PRIMITIVE(pf_forthword_decrjnz){ PF_STACK_CHECK1(VM_RS, a_int); if (VM_RS->first->w.w_int <= 0) return e_inval; // sucks ay.. //PF_ASSERT(VM_RS->first->t == a_int); if (--(VM_RS->first->w.w_int)) JMP else SKIP; } /* pass to subroutine: pop return stack, update ip and execute xt */ static PF_PRIMITIVE(pf_forthword_do_pass){ set_current(vm, vm->ip->w.w_atom_pointer); // get xt PF_STACK_CHECK1(VM_RS, a_atom_pointer); vm->ip = pf_list_pop(VM_RS).w_atom_pointer; // pop ip return execute_current(vm); // execute } /* simple router: strict equality */ static PF_PRIMITIVE(pf_forthword_do_route){ CHECKN(2); int eq1,eq2; eq1 = (ARG0->t == ARG1->t); eq2 = (ARG0->w.w_int == ARG1->w.w_int); DROP1; if (eq1 && eq2) { DROP1; TAIL(pf_forthword_do_pass); } else SKIP; } /* simple forwarder: strict equality */ static PF_PRIMITIVE(pf_forthword_do_forward){ CHECKN(2); int eq1,eq2; eq1 = (ARG0->t == ARG1->t); eq2 = (ARG0->w.w_int == ARG1->w.w_int); DROP1; if (eq1 && eq2) { TAIL(pf_forthword_do_pass); } else SKIP; } /* ( -- ) */ static PF_PRIMITIVE(block_microsleep){ pf_error_t e; struct timeval tv = {0, 10000}; // default 10 ms max /* all PF io is non-blocking, so if io fails (EAGAIN) before the scheduler is loaded, we need to do a 'busy loop'. the only way to do that on a multitasking OS is to sleep, which yields control to other OS tasks. */ select(0, NULL, NULL, NULL, &tv); EXIT; } static PF_PRIMITIVE(pf_forthword_leave); static PF_PRIMITIVE(pf_forthword_abort); /* error handler for exceptions called from within the inner interpreter. when this exits, the execution context should be modified, such that execution can resume to either -> specific error handler -> global error handler 'abort' both are passed the error condition on the DS the condition is passed on DS */ // throw error from highlevel code: ( error -- ) PF_PRIMITIVE(pf_forthword_throw){ int n; pf_atom_t *a; pf_error_t e1, e2; PF_ASSERT(ARG0); // pf_debug_post_stack(s); // PF_ASSERT(atom_error(ARG0)); /* move error so we can put it back after cleaning up the stack */ pf_atom_t *error = pf_list_pop_atom(VM_DS); /* look for exception marker */ n = 0; // number of items to drop a = VM_RS->first; while (a){ if (a->t == a_forth_exception) break; a = a->next; n++; } /* if no exception marker is found then abort */ if (!a){ pf_list_push_atom(VM_DS, error); // push error atom TAIL(pf_forthword_abort); } /* rewind RS and DS */ while (n--){ pf_stack_drop(VM_RS); } int data_depth = pf_list_pop(VM_RS).w_int; PF_ASSERT(data_depth >= 0); while (VM_DS->elements > data_depth){ pf_stack_drop(VM_DS); } while (VM_DS->elements < data_depth) { // pf_post("WARNING: creating %d fake atoms to fill up stack.", // data_depth - VM_DS->elements); // FIXME: try to avoid this.. check where this happens with warning pf_list_push(VM_DS, a_undef, (pf_word_t)0); // fill with dummy cells } /* push error condition */ pf_list_push_atom(VM_DS, error); TAIL(pf_forthword_leave); // 'leave into' rewound context } // throw error from lowlevel code pf_error_t pf_vm_throw_trampoline(pf_vm_t *vm, pf_error_t e, pf_packet_t errorstring) { pf_list_t *error = pf_list_new(); pf_list_push_list(VM_DS, error); pf_list_push_packet(error, errorstring); pf_list_push(error, a_error, (pf_word_t)e); // indicate error is placed on DS (see pf_vm_resume) return e_user; } // or-throw: rethrow if exception does not match // implemented as primitive because comparison // is a polyword and uses exceptions // ( e e -- e ) PF_PRIMITIVE(pf_forthword_throw); static PF_PRIMITIVE(pf_forthword_orthrow){ CHECKN(2); pf_error_t e1, e2; if ((e1 = atom_error(ARG0)) & (e2 = atom_error(ARG1))) { DROP1; if (e1 == e2) { EXIT; } // FIXME: what's correct? TAIL(pf_forthword_throw); } THROW(e_inval, "or-throw needs 2 error arguments"); } /* install a handler R( -- emarker ) return stack rewinding is determined by marker location data stack rewinding is determined by marker contents */ static PF_PRIMITIVE(pf_forthword_install_emarker){ pf_list_push(VM_RS, a_forth_exception, (pf_word_t)(VM_DS->elements)); EXIT; } /* interpreter loop: enter forth and execute until error resume behaves like 'yield to coroutine'. the forth has it's own stacks. it does not need and so does not use the c stack for recursion. if you want pf_execute and friends to behave like ordinary functions (call + return) you need to synchronize with the c stack manually. (see the pd message send code in libpf/pf.c in the pf distribution) */ pf_error_t pf_vm_resume(pf_vm_t *vm){ pf_error_t e; next: /* run until a primive generates an error */ while(!(e = single_step(vm))); error: /* some error codes indicate 'exit interpreter to C caller' see pf/list.h for more info */ if (e <= e_exit) goto exit; /* primitives can either return an error, or use the 'THROW' macro * which will already put the macro on the stack. */ if (e != e_user) { pf_list_push(VM_DS, a_error, (pf_word_t)(int)e); } /* throw the error this either executes a handler on the return stack or falls into 'abort' */ TRY(pf_forthword_throw); goto next; exit: return e; } pf_error_t pf_vm_execute(pf_vm_t *vm){ pf_error_t e; TRY(pf_forthword_execute); e = pf_vm_resume(vm); error: return e; } static PF_PRIMITIVE(c_yield){ return e_idle; } static PF_PRIMITIVE(pf_forthword_undefined); /*** COMPILER + CODEFIELDS ***/ /* comma ( atom -- ) */ static PF_PRIMITIVE(pf_forthword_comma) { CHECKN(1); pf_vm_comma_atom(vm, pf_list_pop_atom(s)); EXIT; } /* here ( -- atom.pointer ) */ static PF_PRIMITIVE(pf_forthword_here) { pf_list_t *link = last_link(vm); pf_list_push(s, a_atom_pointer, (pf_word_t)link->last); EXIT; } /* compile a literal */ static PF_PRIMITIVE(pf_forthword_literal){ pf_error_t e; CHECKN(1); PF_ASSERT(vm->xt_lit); pf_list_push(s, a_forth_xt, (pf_word_t)vm->xt_lit); TRY(pf_forthword_comma); TRY(pf_forthword_comma); EXIT; error: return e; } /* immediate */ static PF_PRIMITIVE(pf_forthword_immediate){ immediate(vm); EXIT; } /* enter subroutine */ static PF_PRIMITIVE(pf_forthword_enter){ pf_list_push(VM_RS, a_atom_pointer, (pf_word_t)vm->ip); vm->ip = vm->current->next; EXIT; } /* do variable */ static PF_PRIMITIVE(pf_forthword_dovar){ PF_ASSERT(vm->current->next); pf_list_push_atom_pointer(s, vm->current->next); EXIT; } /* do constant */ static PF_PRIMITIVE(pf_forthword_doconst){ PF_ASSERT(vm->current->next); pf_stack_push_atom(s, vm->current->next); EXIT; } /* do defer */ static PF_PRIMITIVE(pf_forthword_dodefer){ PF_ASSERT(vm->current->next); if (vm->current->next->t != a_forth_xt){ THROW(e_inval, "invalid defer body"); } pf_stack_push_atom(s, vm->current->next); TAIL(pf_forthword_execute); } /* do does codefield structure looks like ( dodoes code.pfa orig.cf data ) */ static PF_PRIMITIVE(pf_forthword_dodoes) { PF_ASSERT(vm->current->next); PF_ASSERT(vm->current->next->t == a_forth_codefield); /* enter does> code */ pf_list_push(VM_RS, a_atom_pointer, (pf_word_t)vm->ip); vm->ip = vm->current->next->w.w_pointer; // enter does> code /* execute original codefield */ set_current(vm, vm->current->next->next); return execute_current(vm); } static PF_PRIMITIVE(pf_forthword_do_pass); /* compilation */ /* insert a codefield to head of cf array */ static void insert_codefield(pf_list_t *link, void *stuff){ pf_atom_t *a = PF_LINK_TO_BEFORE_CF(link); // add after compiler field pf_atom_t *cf = pf_atom_new(); cf->t = a_forth_codefield; cf->w.w_pointer = stuff; cf->next = a->next; a->next = cf; link->elements++; } /* provided as a primitive for convenience ( pfa -- ) this will leave the original cf intact, so does> merely is an additional, not a replacement codefield */ static PF_PRIMITIVE(pf_forthword_install_dodoes){ CHECK1(a_atom_pointer); pf_list_t *link = last_link(vm); /* insert new codefield atoms */ insert_codefield(link, pf_list_pop(s).w_pointer); //pfa of highlevel code insert_codefield(link, pf_forthword_dodoes); //code EXIT; } static PF_PRIMITIVE(pf_forthword_left_bracket){vm->state = 0; EXIT;} static PF_PRIMITIVE(pf_forthword_right_bracket){vm->state = 1; EXIT;} /*** OUTER INTERPRETER ***/ /* from http://www.zetetics.com/bj/papers/moving6.htm 4. QUIT resets the return stack pointer, loop stack pointer, and interpret state, and then begins to interpret Forth commands. (The name is apt because QUIT can be used to abort an application and get back to the "top level" of Forth. Unlike ABORT, QUIT will leave the parameter stack contents alone.) QUIT is an infinite loop which will ACCEPT a line from the keyboard, and then INTERPRET it as Forth commands. When not compiling, QUIT will prompt "ok" after each line. we do it a bit different here * quit is only defined for the readline console. in normal (headless) operation the forth acts like a unix script interpreter, and quit is not defined. * abort will call an abort handler on the abort stack. this is an alternative to exception handlers (abort handlers are called whenever there is no exception on the return stack) * accept and interpret do not work on lines, but on atoms at a time. 'parsing words' call accept. since we use exceptions, we can't just jump through stackframes, since the exceptions are there to clean up things. so quit in console.pf should throw an exception. */ static void print_error(pf_atom_t *a){ pf_error_t e = atom_error(a); char *msg = atom_error_msg(a); pf_post("%s: %s", pf_error(e), msg ? msg : ""); // pf_debug_post_stack(s); } /* abort: this is called whenever an error occurs and there is no exception handler present on the return stack. */ static PF_PRIMITIVE(pf_forthword_abort){ pf_atom_t *abort = vm->abort; // get abort vector if (abort && abort->t == a_forth_xt){ pf_list_push(VM_DS, a_forth_xt, (pf_word_t)abort->w.w_atom_pointer); TAIL(pf_forthword_execute); } else { if (VM_DS->elements){ print_error(ARG0); //PF_ASSERT(0 && "abort problem"); } pf_post("No global abort handler. This error is fatal."); vm->state = 0; while (VM_DS->elements) pf_stack_drop(VM_DS); return e_abort; } } /* depending on state, transform the xt on TOS to a ct */ static PF_PRIMITIVE(pf_forthword_semantics){ CHECK1(a_forth_xt); if (vm->state){ pf_list_t *link = PF_XT_TO_LNK(ARG0->w.w_atom_pointer); if (!link){ THROW(e_inval, "xt is not part of link"); } pf_list_push(s, a_forth_xt, (pf_word_t)(PF_LINK_TO_COMPILER(link)->w.w_pointer)); } EXIT; } /* interpret atom ( atom -- ? ) */ static PF_PRIMITIVE(pf_forthword_interpret){ CHECKN(1); // D { pf_post_n("interpreting: "); pf_post_atom(ARG0); } if(ARG0->t == a_symbol){ // symbols are translated to xt pf_symbol_t *name = ARG0->w.w_symbol; pf_list_t *link = pf_vm_lookup_link(vm, name); pf_error_t e = e_internal; if (!link){ TAIL(pf_forthword_undefined); } // replace symbol with xt ARG0->t = a_forth_xt; ARG0->w.w_atom_pointer = PF_LINK_TO_XT(link); // ( xt -- xt/ct ) convert symantics depending on state TRY_THROW(pf_forthword_semantics); // exec execution or compilation semantics TAIL(pf_forthword_execute); } else { // all the other atom types are treated as literals if (vm->state) {TAIL(pf_forthword_literal);} else {EXIT;} } } static PF_PRIMITIVE(pf_forthword_bootcolon){ CHECK1(a_symbol); pf_vm_add_primitive(vm, pf_list_pop(s).w_symbol, pf_forthword_enter); vm->state = 1; EXIT; } /* finish highlevel word definition */ static PF_PRIMITIVE(pf_forthword_semicolon){ PF_ASSERT(vm->xt_leave); pf_vm_comma(vm, a_forth_xt, (pf_word_t)vm->xt_leave); vm->state = 0; EXIT; } /* this ends a definition with a tailcall. the goal is to have this as default. * normal xt: replace last with tailljmp last * jump target: can't perform tailcall * part of literal: take previous */ static PF_PRIMITIVE(pf_forthword_semisemicolon){ // find previous atom (TODO: abstract this in function) char *reason = 0; pf_list_t *link = last_link(vm); pf_atom_t *a = link->first; PF_ASSERT(a->next); while (a->next != link->last) a = a->next; if (a->t != a_forth_xt){ reason = "previous atom is not an xt"; goto normal; } // check if here is a jump target, or otherwize referenced pf_atom_t *b = link->first; for (; b ; b = b->next){ if (b->t == a_atom_pointer) if (b->w.w_atom_pointer == link->last){ reason = "tail atom referenced in link"; goto normal; } } // compile a tail call pf_atom_t *xt = a->w.w_atom_pointer; PF_ASSERT(vm->xt_do_pass); a->w.w_atom_pointer = vm->xt_do_pass; pf_vm_comma(vm, a_forth_xt, (pf_word_t)xt); vm->state = 0; EXIT; normal: THROW(e_badlink, "can't compile tailcall : %s", reason); } /* return from subroutine: pop return stack and update ip */ static PF_PRIMITIVE(pf_forthword_leave){ if (!VM_RS->elements){ THROW(e_exec, "no more elements on return stack."); } if (VM_RS->first->t != a_atom_pointer){ THROW(e_exec, "RS top is not a_atom_pointer."); } vm->ip = pf_list_pop(VM_RS).w_atom_pointer; EXIT; } /* transfer (jump / tail call) to XT */ /* transfer to threaded code */ // ((x->t != a_undef) && ((x->t != a_int) || (x->w.w_int))) /* move TOS to top of return stack */ static PF_PRIMITIVE(pf_forthword_tor){ CHECKN(1); pf_list_push_atom(VM_RS, pf_list_pop_atom(s)); EXIT; } /* move top of return stack to TOS */ static PF_PRIMITIVE(pf_forthword_fromr){ PF_STACK_CHECKN(VM_RS, 1); pf_list_push_atom(s, pf_list_pop_atom(VM_RS)); EXIT; } /* load rsp pointer (variable on top of return stack) */ static PF_PRIMITIVE(pf_forthword_rpointer){ PF_STACK_CHECKN(VM_RS, 1); pf_list_push(VM_DS, a_atom_pointer, (pf_word_t)VM_RS->first); EXIT; } /* drop top of return stack */ static PF_PRIMITIVE(pf_forthword_rdrop){ return pf_stack_drop(VM_RS); EXIT; } /* same, but no pop */ static PF_PRIMITIVE(pf_forthword_rtop){ PF_STACK_CHECKN(VM_RS, 1); pf_stack_push_atom(VM_DS, VM_RS->first); EXIT; } /* swap for rs */ static PF_PRIMITIVE(pf_forthword_rswap){ pf_word_t w; pf_word_type_t t; PF_STACK_CHECKN(VM_RS, 2); w = VM_RS->first->w; t = VM_RS->first->t; VM_RS->first->w = VM_RS->first->next->w; VM_RS->first->t = VM_RS->first->next->t; VM_RS->first->next->w = w; VM_RS->first->next->t = t; EXIT; } /* next 3 are return stack magic ops */ /* wind */ static PF_PRIMITIVE(pf_forthword_rwind){ pf_list_t *rs = pf_list_new(); pf_list_push_list(rs, VM_RS); VM_RS = rs; EXIT; } /* unwind */ static PF_PRIMITIVE(pf_forthword_runwind){ if (!VM_RS->elements) return e_underflow; if (VM_RS->last->t != a_list) return e_type; pf_list_t *rs = VM_RS->last->w.w_list; VM_RS->last->t = a_undef; // move RS VM_RS->last->w.w_int = 0; pf_stack_free(VM_RS); VM_RS = rs; EXIT; } /* DICTIONARY MANIPULATION */ /* (name -- ) create a new link in the current dictionary the link contains name and default compilation word ',' */ static PF_PRIMITIVE(pf_forthword_link) { CHECK1(a_symbol); create_link(vm, pf_list_pop(s).w_symbol); EXIT; } /* dictionary lookup ( symbol -- xt ) */ static PF_PRIMITIVE(pf_forthword_find) { CHECK1(a_symbol); pf_list_t *link = pf_vm_lookup_link(vm, ARG0->w.w_symbol); if (!link){ TAIL(pf_forthword_undefined); } pf_list_pop(s); pf_list_push(s, a_forth_xt, (pf_word_t)PF_LINK_TO_XT(link)); EXIT; } // find something in a dictionary outside of vm ( symbol dict.var -- xt ) static PF_PRIMITIVE(pf_forthword_dict_find) { CHECK2(a_atom_pointer, a_symbol); if (!ARG0->w.w_atom_pointer) return e_pointer; if (ARG0->w.w_atom_pointer->t != a_list) return e_type; pf_list_t *dict = ARG0->w.w_atom_pointer->w.w_list; pf_symbol_t *name = ARG1->w.w_symbol; pf_list_t *link = lookup_link(dict, name); if (!link) goto undef; DROP1; DROP1; pf_list_push(s, a_forth_xt, (pf_word_t)PF_LINK_TO_XT(link)); EXIT; undef: PUSH_SYMBOL(name); TAIL(pf_forthword_undefined); } static PF_PRIMITIVE(pf_forthword_is_defined) { CHECK1(a_symbol); pf_list_t *link = pf_vm_lookup_link(vm, pf_list_pop(s).w_symbol); pf_list_push(s, a_int, (pf_word_t)(link ? -1 : 0)); EXIT; } /* all undefined errors will come through this gate */ static PF_PRIMITIVE(pf_forthword_undefined){ // ( symbol -- ) CHECK1(a_symbol); char *sname = ARG0->w.w_symbol->s_name; // pf_post(" undefined word %s", sname); THROW(e_undef, "unbound symbol '%s'", sname); } // FIXME: this is because of dodoes (non-constant codefield width) /* ( xt -- body ) */ static PF_PRIMITIVE(pf_forthword_xt_to_body) { pf_atom_t *a; CHECK1(a_forth_xt); PF_ASSERT(ARG0->w.w_atom_pointer->t == a_forth_codefield); // xt points to codefield a = ARG0->w.w_atom_pointer; while (a->t == a_forth_codefield) a = a->next; // but can be more than 1 ARG0->t = a_atom_pointer; ARG0->w.w_atom_pointer = a; // after that, there's body EXIT; } static PF_PRIMITIVE(pf_forthword_latestxt) { pf_list_push(s, a_forth_xt, (pf_word_t) PF_LINK_TO_XT(last_link(vm))); EXIT; } /* VARIABLE ACCES */ /* ( value ptr -- ) + store value in location */ /* if variable locking is ever needed, this is where it should be implemented, together with some c api functions to lock from the c side */ static PF_PRIMITIVE(pf_forthword_store) { CHECKN(2); /* atom pointer */ if (ARG0->t == a_atom_pointer){ pf_atom_t *a = ARG0->w.w_atom_pointer; if (!a || pf_atom_stale(a)) return a_pointer; // check pointer before deref pf_list_pop(s); // delete pointer from stack // inplace replace pf_stackatom_clear(a); a->t = ARG0->t; a->w = ARG0->w; } /* ordinary pointer: copy verbatim */ else if (ARG0->t == a_pointer){ pf_word_t *w; w = ARG0->w.w_pointer; pf_list_pop(s); // delete pointer from stack *w = ARG0->w; // store word in memory location } /* no pointer: type error */ else { return e_type; } /* remove variable */ pf_list_pop(s); EXIT; } /* ( atomptr -- val ) normal fetch operator: copies the atom */ static PF_PRIMITIVE(pf_forthword_fetchcopy) { pf_atom_t *a; CHECK1(a_atom_pointer); a = ARG0->w.w_atom_pointer; PF_ATOM_CHECK_READ(a); DROP1; pf_stack_push_atom(s, a); EXIT; } /* ( atomptr -- val ) special fetch operator: move to stack (instead of copy) content of source var will be undefined after this */ static PF_PRIMITIVE(pf_forthword_fetchmove) { pf_atom_t *a; CHECK1(a_atom_pointer); a = ARG0->w.w_atom_pointer; PF_ATOM_CHECK_READ(a); // move it ARG0->t = a->t; ARG0->w = a->w; a->t = a_undef; // clear source var a->w.w_int = -1; // remove dangling ref for safety EXIT; } /* STACK MAGIC */ /* swap the list on TOS with data stack */ static PF_PRIMITIVE(pf_forthword_swapdata) { pf_list_t *l; CHECK1(a_list); l = pf_list_pop(s).w_list; pf_list_push(l, a_list, (pf_word_t)s); VM_DS = l; EXIT; } /* swap the list on TOS with return stack */ static PF_PRIMITIVE(pf_forthword_swapreturn) { CHECK1(a_list); pf_list_t *l = ARG0->w.w_list; ARG0->w.w_list = VM_RS; VM_RS = l; EXIT; } /* perform a task switch. swap both stacks at the same time. TOS contains ( returnstack datastack ) */ static PF_PRIMITIVE(pf_forthword_swap_rs_ds) { pf_list_t *task; pf_list_t *ds,*rs; CHECK1(a_list); task = ARG0->w.w_list; PF_STACK_CHECK2(task, a_list, a_list); pf_list_pop(s); ds = VM_DS; rs = VM_RS; VM_RS = task->first->w.w_list; VM_DS = task->first->next->w.w_list; task->first->w.w_list = rs; task->first->next->w.w_list = ds; pf_list_push(VM_DS, a_list, (pf_word_t)task); EXIT; } static pf_list_t *wordlist(pf_vm_t *vm); static PF_PRIMITIVE(pf_forthword_current_abort){ pf_atom_t *a = pf_atom_new(); a->t = a_atom_pointer; a->w.w_atom_pointer = vm->abort; pf_list_push_atom(s, a); EXIT; } /* MISC */ static PF_PRIMITIVE(pf_forthword_state){ PUSH_INT(vm->state); EXIT; } // convert xt to a link head pointer (debug) static PF_PRIMITIVE(pf_forthword_linkhead){ CHECKN(1); switch(ARG0->t){ default: return e_type; case a_atom_pointer: case a_forth_xt: break; } pf_atom_t *xt; pf_list_t *link; if (!(xt = ARG0->w.w_atom_pointer)) return e_pointer; if (!(link = PF_XT_TO_LNK(xt))){ THROW(e_inval, "xt/ip is not part of link"); } ARG0->t = a_atom_pointer; ARG0->w.w_atom_pointer = link->first; EXIT; } // pop last link static PF_PRIMITIVE(pf_forthword_fromd){ PF_STACK_CHECKN(vm->allot_stack, 1); pf_list_push_atom(s, pf_list_pop_atom(vm->allot_stack)); EXIT; } // push link static PF_PRIMITIVE(pf_forthword_tod){ CHECKN(1); pf_list_push_atom(vm->allot_stack, pf_list_pop_atom(s)); EXIT; } static PF_PRIMITIVE(pf_forthword_lit){ pf_atom_t *a = vm->ip; if (a){ vm->ip = vm->ip->next; pf_stack_push_atom(s, a); EXIT; } THROW(e_exec, "improper link termination at literal."); } static void clearstruct(pf_vm_t *vm) { /* init mem: remove dangling refs */ memset(vm, 0, sizeof(*vm)); } static void clear_io_atom(pf_atom_t *a){ pf_stackatom_drop(a); a = pf_atom_new(); a->t = a_undef; a->w.w_int = 0; } /* reset everything except dictionary and input/output */ void pf_vm_softreset(pf_vm_t *vm) { pf_stack_clear(vm->return_stack); pf_stack_clear(vm->data_stack); vm->current = 0; vm->state = 0; } /* destructor */ void pf_vm_cleanup(pf_vm_t *vm) { /* empty */ pf_vm_softreset(vm); // DS RS AS pf_stack_clear(vm->allot_stack); // dict /* remove components */ pf_stack_free(vm->data_stack); pf_stack_free(vm->return_stack); pf_stack_free(vm->allot_stack); /* remove dangling references */ clearstruct(vm); } // should keep a list of all VMs void pf_exit_program(int exitcode){ pf_vm_cleanup(pf_forth_vm()); exit(exitcode); } static PF_PRIMITIVE(pf_forthword_bye_retval){ CHECKN(1); int retval = INT(ARG0); pf_vm_cleanup(vm); exit(retval); } /* constructor */ void pf_vm_init(pf_vm_t *vm) { pf_list_t *link = 0; clearstruct(vm); vm->data_stack = pf_list_new(); vm->return_stack = pf_list_new(); vm->allot_stack = pf_list_new(); vm->abort = pf_atom_new(); vm->state = 0; vm->ip = 0; } /* hard reset machine */ void pf_vm_reset(pf_vm_t *vm) { pf_vm_cleanup(vm); pf_vm_init(vm); } pf_vm_t *pf_vm_new(){ pf_vm_t *vm = pf_alloc(sizeof(pf_vm_t)); pf_vm_init(vm); return vm; } void pf_vm_free(pf_vm_t *vm){ pf_vm_cleanup(vm); pf_dealloc(vm); } /* DICTIONARY */ /* return a list with all words visible to vm */ static pf_list_t *wordlist(pf_vm_t *vm) { pf_list_t *words = pf_list_new(); pf_atom_t *a = vm->allot_stack->first; while (a && (a->t == a_list)){ pf_list_t *link = a->w.w_list; if (pf_list_is_link(link)) if (link->first && (link->first->t == a_symbol)) pf_list_push_symbol(words, link->first->w.w_symbol); a = a->next; } return words; } static PF_PRIMITIVE(pf_forthword_getwordlist) { pf_list_t *words = wordlist(vm); PUSH_LIST(words); EXIT; } static PF_PRIMITIVE(pf_forthword_debug_attach) { pf_debug_attach_debugger(0); EXIT; } static PF_PRIMITIVE(pf_forthword_debug_trap) { pf_debug_trap(); EXIT; } static PF_PRIMITIVE(pf_forthword_malloc_trap){ CHECK2(a_int, a_int); int i; int n = ARG1->w.w_int; int mask = ARG0->w.w_int; void *ptr[n]; for (i=0; iw.w_int); DROP1; EXIT; } static char *home_dir = 0; static PF_PRIMITIVE(pf_forthword_getenv) { CHECK1(a_packet); char *var = STRING(ARG0); if (!var) return e_type; var = getenv(var); if (!var) var = ""; DROP1; PUSH_PACKET(pf_packet_stringf(var)); EXIT; } static PF_PRIMITIVE(pf_forthword_home) { PUSH_PACKET(pf_packet_stringf(home_dir)); EXIT; } static PF_PRIMITIVE(pf_forthword_set_trace){ CHECK1(a_int); trace_mode = pf_list_pop(s).w_int; //trace_depth = -1; EXIT; } static PF_PRIMITIVE(boo){ fprintf(stderr, "boo\n"); EXIT; } static int check_tree(pf_list_t *); static int check_atom(pf_atom_t *a){ int n = 0; switch (a->t){ case a_list: n += check_tree(a->w.w_list); break; /* these are supposed to be the only ones that can cause problems.. we map both to a NULL equivalent. */ case a_forth_xt: case a_atom_pointer: if (a->w.w_atom_pointer->t == a_stale) { a->w.w_atom_pointer = 0; n++; } break; default: break; } return n; } static int check_tree(pf_list_t *l){ int n = 0; pf_atom_t *a = l->first; while (a){ n += check_atom(a); a = a->next; } return n; } static int check_vm(pf_vm_t *vm){ int n = 0; n += check_tree(vm->data_stack); n += check_tree(vm->return_stack); n += check_tree(vm->allot_stack); n += check_atom(vm->ip); n += check_atom(vm->current); return n; } static PF_PRIMITIVE(debug_stack){ pf_debug_post_stack(s); EXIT; } /* drop an atom, then check the whole accessible data tree for stale references, and replace them by null pointers. signal an error if there were stale references found. the reason this works is that atoms/lists are never dealloced, but moved to a free list. upon doing so, they are set to the type a_stale. by checking the data tree right after deleting it, we can catch all of them. */ static PF_PRIMITIVE(pf_forthword_safe_drop){ CHECKN(1); pf_atom_t *a = pf_list_pop_atom(s); pf_stackatom_drop(a); int n = check_vm(vm); if (n){ PUSH_INT(n); THROW(e_pointer, "found %d stale references during safe drop", n); } EXIT; } /* dictionary setup */ static pf_vm_t *_pf_forth_vm; // the global vm used for initialization etc.. pf_vm_t *pf_forth_vm(void){return _pf_forth_vm;} /* SETUP CODE */ /* bootstrap the forth: define and cache most basic primitives: , execute leave lit do_pass */ #define REGISTER_PRIMITIVE PF_REGISTER_FUNCTION static void bootstrap(void) { pf_list_t *link; /* init global vm */ pf_vm_t *vm = _pf_forth_vm = pf_alloc(sizeof(pf_vm_t)); pf_vm_init (vm); /* bootstrap dict: first word ',' needs to be created manually (xt_comma not initialized) */ link = create_link(vm, pf_symbol(",")); vm->xt_comma = PF_LINK_TO_XT(link); PF_LINK_TO_COMPILER(link)->w.w_pointer = vm->xt_comma; pf_vm_comma(vm, a_forth_codefield, (pf_word_t)pf_forthword_comma); /* some more cached xt's */ REGISTER_PRIMITIVE(pf_forthword_execute, "execute", "( xt -- )\tExecute token."); REGISTER_PRIMITIVE(pf_forthword_leave, "leave", "( -- )\tLeave current definition."); REGISTER_PRIMITIVE(pf_forthword_lit, "lit", "( -- a )\tLoad next atom as literal."); REGISTER_PRIMITIVE(pf_forthword_do_pass, "do-pass", "( -- )\tTailcall next xt."); cache_xt(vm); } /* add kernel primitives to global forth dictionary */ static PF_PRIMITIVE(register_primitives) { /* compilation & dict */ REGISTER_PRIMITIVE(pf_forthword_link, "link", "( name -- )\tAppend a new link to the current dictionary."); REGISTER_PRIMITIVE(pf_forthword_latestxt, "latestxt", "( -- xt )\tReturn xt of last link."); REGISTER_PRIMITIVE(pf_forthword_literal, "literal,", "( atom -- )\tCompiles a literal atom."); REGISTER_PRIMITIVE(pf_forthword_literal, "literal", "( atom -- )\tCompiles a literal atom. Immediate."); immediate(pf_forth_vm()); REGISTER_PRIMITIVE(pf_forthword_bootcolon, "boot-colon", "( symbol -- )\tBootstrap colon replacement."); immediate(pf_forth_vm()); REGISTER_PRIMITIVE(pf_forthword_semicolon, ";", "End of word definition. Immediate."); immediate(pf_forth_vm()); REGISTER_PRIMITIVE(pf_forthword_semisemicolon, ";;", "End of word definition. Tail call. Immediate."); immediate(pf_forth_vm()); REGISTER_PRIMITIVE(pf_forthword_abort, "abort", "Jump to interpreter. Resets compile mode and datastack."); REGISTER_PRIMITIVE(pf_forthword_immediate, "immediate", "Mark last link as immediate."); REGISTER_PRIMITIVE(pf_forthword_dict_find, "dict-find", "( symbol var.dict -- xt )\tLookup a symbol a dictionary."); REGISTER_PRIMITIVE(pf_forthword_find, "find", "( symbol -- xt )\tLookup the symbol in the current dictionary."); REGISTER_PRIMITIVE(pf_forthword_is_defined, "defined?", "( symbol -- bool )\tCheck if a symbol is defined."); REGISTER_PRIMITIVE(pf_forthword_xt_to_body, "xt>body", "( xt -- pf )\tConvert an xt to the body of a word (which can contain threaded code or data)."); REGISTER_PRIMITIVE(pf_forthword_enter, "enter", "Codefield to enter a list of threaded code."); REGISTER_PRIMITIVE(pf_forthword_dovar, "dovar", "Codefield to load the adress of a variable in body."); REGISTER_PRIMITIVE(pf_forthword_doconst, "doconst", "Codefield to load the value of a constant in body."); REGISTER_PRIMITIVE(pf_forthword_dodefer, "dodefer", "Codefield to execute an xt contained in body."); REGISTER_PRIMITIVE(pf_forthword_dodoes, "dodoes", "Codefield for does> words."); REGISTER_PRIMITIVE(pf_forthword_install_dodoes, "install-dodoes", "install-dodoes codefield"); REGISTER_PRIMITIVE(pf_forthword_left_bracket, "[", "Enter interpret mode. Immediate."); immediate(pf_forth_vm()); REGISTER_PRIMITIVE(pf_forthword_right_bracket, "]", "Enter compile mode."); /* control flow */ REGISTER_PRIMITIVE(pf_forthword_case, "+;;", "( n -- )\tPass to nth xt."); REGISTER_PRIMITIVE(pf_forthword_jmp, "jmp", "( -- )\tBranch to threaded code."); REGISTER_PRIMITIVE(pf_forthword_jnz, "jnz", "( condition -- )\tBranch to threaded code if nonzero."); REGISTER_PRIMITIVE(pf_forthword_decrjnz, "decrjnz", "Decrement top of return stack. Jump if nonzero."); REGISTER_PRIMITIVE(pf_forthword_jz, "jz", "( condition -- )\tBranch to threaded code if zero."); REGISTER_PRIMITIVE(pf_forthword_here, "here", "( -- atompointer )\tReturn 'top of dictionary' variable."); REGISTER_PRIMITIVE(pf_forthword_do_route, "do-route", "( a b -- )\tPass control to next xt if equal, else skip."); REGISTER_PRIMITIVE(pf_forthword_do_forward, "do-forward", "( a b -- a )\tPass control to next xt if equal, else skip."); REGISTER_PRIMITIVE(pf_forthword_here, "here", "( -- atompointer )\tReturn 'top of dictionary' variable."); /* return stack access */ REGISTER_PRIMITIVE(pf_forthword_tor, ">r", "( thing -- ) ( -- thing R)\tMove an atom to the return stack"); REGISTER_PRIMITIVE(pf_forthword_fromr, "r>", "( -- thing ) ( thing -- R)\tMove an atom from the return stack"); REGISTER_PRIMITIVE(pf_forthword_rtop, "r", "( -- thing )\tLoad the atom on top of RS on DS."); REGISTER_PRIMITIVE(pf_forthword_rdrop, "rdrop", "( thing -- R)\tDrop atom on top of RS."); REGISTER_PRIMITIVE(pf_forthword_rswap, "rswap", "( a b -- b a R)\tSwap elements on RS."); REGISTER_PRIMITIVE(pf_forthword_rpointer, "rsp", "( -- rsp)\tGet return stack pointer."); REGISTER_PRIMITIVE(pf_forthword_rwind, "rwind", "wind RS"); REGISTER_PRIMITIVE(pf_forthword_runwind, "runwind", "unwind RS"); /* state swapping */ REGISTER_PRIMITIVE(pf_forthword_install_emarker, "emarker>r", "( -- emarker R)\tInstall an exception marker on the return stack."); REGISTER_PRIMITIVE(pf_forthword_orthrow, "or-throw", "( e1 e2 -- e1 )\tRethrow last if e1 != e2."); REGISTER_PRIMITIVE(pf_forthword_throw, "throw", "( exception -- )\tThrow an exception."); REGISTER_PRIMITIVE(pf_forthword_swapreturn, "swapreturn", "( new.RS -- old.RS )\tSwap return stack."); REGISTER_PRIMITIVE(pf_forthword_swapdata, "swapdata", "( new.DS -- old.DS )\tSwap date stack."); /* variable access */ REGISTER_PRIMITIVE(pf_forthword_store, "!", "( value variable -- )\tStore a value in a variable, overwriting any previous contents."); REGISTER_PRIMITIVE(pf_forthword_fetchcopy, "@", "( variable -- value )\tCopy the value of a variable."); REGISTER_PRIMITIVE(pf_forthword_fetchmove, "@>", "( varaible -- value )\tMove the value of a variable, replacing original with undef."); /* dictionary */ REGISTER_PRIMITIVE(pf_forthword_fromd, "d>", "( -- atom )\tPop atom (link) from top of dictionary."); REGISTER_PRIMITIVE(pf_forthword_tod, ">d", "( atom -- )\tPush atom (link) to top of dictionary."); /* misc */ REGISTER_PRIMITIVE(pf_forthword_getwordlist, "words", "( -- list )\tReturn a list with all words."); REGISTER_PRIMITIVE(pf_forthword_home, "homedir", "( -- string )\tGet the forth library home."); REGISTER_PRIMITIVE(pf_forthword_getenv, "getenv", "( variable -- value )\tGet environment variable."); REGISTER_PRIMITIVE(pf_forthword_cache_xt, "update-xt-cache", "( -- )\tUpdate C kernel xt cache."); REGISTER_PRIMITIVE(pf_forthword_set_trace, ">trace", "( flag -- )\tSet/unset instruction trace dump."); /* debug */ REGISTER_PRIMITIVE(debug_stack, "debug-stack", "( -- )"); REGISTER_PRIMITIVE(pf_forthword_malloc_trap, "malloc-trap", "( chunks mask -- )\tRandom allocation test."); REGISTER_PRIMITIVE(pf_forthword_safe_drop, "safe-drop", "( thing -- )\tReturn number of stale pointers in this VM after dropping thing."); REGISTER_PRIMITIVE(pf_forthword_debug_trap, "gdb-trap", "Raise SIGTRAP to fall into debugger (gdb)."); REGISTER_PRIMITIVE(pf_forthword_debug_attach, "gdb-attach", "Attach a gdb process to the current process."); REGISTER_PRIMITIVE(pf_forthword_debug_assert, "gdb-assert", "( condition -- )\tAssert. Depending on configuration this attaches a debugger."); REGISTER_PRIMITIVE(pf_forthword_linkhead, "linkhead", "( xt -- pointer )\tConvert an xt to a link head pointer."); REGISTER_PRIMITIVE(pf_forthword_word_name, "word-name", "( atompointer -- symbol )\tConvert atom pointer to link name or "); /* outer interpreter */ REGISTER_PRIMITIVE(pf_forthword_semantics, "semantics", "( xt -- xt/ct )\tDepending on interpreter state, convert to xt or ct."); REGISTER_PRIMITIVE(pf_forthword_interpret, "interpret", "( atom -- ? )\tInterpret atom. (Depends on interpret state)."); REGISTER_PRIMITIVE(pf_forthword_current_abort, "current-abort", "( -- var )\tCurrent abort variable."); REGISTER_PRIMITIVE(pf_forthword_state, "state", "( -- int )\tGet interpreter state."); // get state REGISTER_PRIMITIVE(pf_forthword_bye_retval, "bye-exitcode", "( exitcode -- )\tQuit PF freeing all data structures."); REGISTER_PRIMITIVE(block_microsleep, "block-microsleep", "( -- )\tSuspend PF for a couple of microseconds."); REGISTER_PRIMITIVE(c_yield, "c-yield", "( -- )\tYield to parent C code."); REGISTER_PRIMITIVE(boo, "boo", "( -- )\tBoo!"); EXIT; } /* compile an xt NOTE: this does not make use of compile semantics just here to support setup_forth() */ static void compile_word(pf_vm_t *vm, char *name){ pf_vm_comma(vm, a_forth_xt, (pf_word_t)PF_LINK_TO_XT(pf_vm_lookup_link(vm, pf_symbol(name)))); } /* create bootstrap highlevel words accept & interpret and idle task */ static pf_list_t *colon(pf_vm_t *vm, char *name){ return pf_vm_add_primitive(vm, pf_symbol(name), pf_forthword_enter); } static pf_list_t *variable(pf_vm_t *vm, char *name){ return pf_vm_add_primitive(vm, pf_symbol(name), pf_forthword_dovar); } static void compile_string (pf_vm_t *vm, char *str) { compile_word(vm, "lit"); pf_vm_comma(vm, a_packet, (pf_word_t)pf_packet_stringf("%s", str)); } /* generate the code that will start forth from a file */ static void setup_forth(char *setup_filename, pf_list_t *args){ pf_vm_t *vm = pf_forth_vm(); pf_list_t *link; /* bootstrap accept */ link = colon(vm, "boot-read"); compile_word(vm, "lit"); pf_atom_t *input_stream_variable = link->last; compile_word(vm, "nop"); // dummy var compile_word(vm, "read-atom-boot"); compile_word(vm, "leave"); /* read */ link = colon(vm, "read"); PF_LINK_TO_CFA(link)->w.w_primitive = pf_forthword_dodefer; compile_word(vm, "boot-read"); /* args */ link = variable(vm, "args"); pf_vm_comma(vm, a_list, (pf_word_t)args); /* colon */ link = colon(vm, ":"); compile_word(vm, "read"); compile_word(vm, "boot-colon"); compile_word(vm, "leave"); /* interpreter */ // link = colon(vm, "boot-interpreter"); /* go forth! */ vm->ip = link->last; compile_string(vm, setup_filename); compile_string(vm, "r"); compile_word(vm, "open-file"); compile_word(vm, "lit"); pf_vm_comma(vm, a_atom_pointer, (pf_word_t)input_stream_variable); compile_word(vm, "!"); // begin pf_atom_t *begin = link->last; compile_word(vm, "read"); compile_word(vm, "interpret"); // again compile_word(vm, "jmp"); pf_vm_comma(vm, a_atom_pointer, (pf_word_t)begin); } void pf_forth_basic(void); PF_PRIMITIVE(pf_forth_errors); PF_PRIMITIVE(pf_forth_unix_setup); PF_PRIMITIVE(pf_forth_select_setup); PF_PRIMITIVE(pf_forth_string_setup); PF_PRIMITIVE(pf_forth_bitgrid_setup); PF_PRIMITIVE(pf_forth_stream_setup); PF_PRIMITIVE(pf_forth_plugin_setup); PF_PRIMITIVE(pf_forth_setup_fw) { pf_error_t e; TRY(pf_forth_errors); TRY(pf_forth_unix_setup); TRY(pf_forth_select_setup); TRY(pf_forth_string_setup); TRY(pf_forth_stream_setup); TRY(pf_forth_bitgrid_setup); TRY(pf_forth_plugin_setup); EXIT; error: return e; } pf_error_t pf_forth_setup(void){ /* core */ bootstrap(); pf_vm_t *vm = pf_forth_vm(); TRY_THROW(register_primitives); /* misc */ pf_forth_basic(); /* forth things */ TRY_THROW(pf_forth_setup_fw); EXIT; } /* load forth library */ // to print error in C code using pf interpreter pf_error_t pf_forth_library_setup(pf_list_t *args) { /* bootstrap interpreter */ char *setup_pf = "/script/setup.pf"; char *home = getenv("PF_HOME"); home_dir = home ? home : PF_HOME; // if not defined use compile time default int n = strlen(home_dir)+strlen(setup_pf)+1; char f[n]; strcpy(f, home_dir); strcat(f, setup_pf); setup_forth(f, args); // this returns when forth is set up return pf_vm_resume(pf_forth_vm()); }