/* * Pure Data Packet - Basic forth words operation on data stack. * 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. * */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #define D if (0) // Most stack operations operate on the VM struct directly. However, // some stack operations are also exported as separate functions. // different prototype: legacy thingy pf_error_t pf_stack_drop(pf_stack_t *s) { if (!s->first) return e_underflow; pf_stackatom_drop(pf_list_pop_atom(s)); return e_ok; } pf_error_t pf_stack_swap(pf_stack_t *s) { if (!s->first) return e_underflow; if (!s->first->next) return e_underflow; pf_atom_t *first = pf_list_pop_atom(s); pf_atom_t *second = pf_list_pop_atom(s); pf_list_push_atom(s, first); pf_list_push_atom(s, second); return e_ok; } pf_error_t pf_stack_dup(pf_list_t *s) { if (!s->first) return e_underflow; pf_stack_push_atom(s, s->first); return e_ok; } /* some stack manips */ /* DUP / DROP: not defined for list / tree */ #define _TRY(x) {pf_error_t e = x; if (e) ABORT (e); EXIT; } PF_PRIMITIVE(pf_forthword_dup) { _TRY(pf_stack_dup(vm->data_stack)); } PF_PRIMITIVE(pf_forthword_swap){ _TRY(pf_stack_swap(vm->data_stack)); } PF_PRIMITIVE(pf_forthword_drop){ _TRY(pf_stack_drop(vm->data_stack)); } PF_PRIMITIVE(pf_forthword_over) { CHECKN(2); pf_stack_push_atom(vm->data_stack, ARG1); EXIT; } /* indexed acces to stack */ PF_PRIMITIVE(pf_forthword_pick) { pf_atom_t *a; CHECKN(1); int index = INT(ARG0); if (index >= (vm->data_stack->elements-1)) ABORT(e_underflow); DROP1; for (a=ARG0; index--; a=a->next); pf_stack_push_atom(vm->data_stack, a); EXIT; } /* pack words from stack into a list */ PF_PRIMITIVE(pf_forthword_pack) { int n; pf_list_t *l; pf_atom_t *a; CHECK1(a_int); n = ARG0->w.w_int; if (vm->data_stack->elements < n+1) ABORT(e_underflow); DROP1; l = pf_list_new(); if (n) { /* find last atom */ vm->data_stack->elements -= n; l->elements += n; for (a=ARG0; --n; a=a->next); /* move chain */ if (vm->data_stack->last == a) vm->data_stack->last = 0; l->first = ARG0; l->last = a; // ARG0 = a->next; // FIXME: list lvalues vm->data_stack->first = a->next; a->next = 0; } PUSH_LIST(l); EXIT; } PF_PRIMITIVE(pf_forthword_unpack) { pf_list_t *l; CHECKN(1); if (!pf_atom_islist(ARG0)) ABORT(e_type); l = pf_list_pop(vm->data_stack).w_list; if (l->elements){ pf_list_join(l, vm->data_stack); vm->data_stack = l; } EXIT; } static void getlistptr_size(pf_vm_t *vm, pf_stack_t *s, pf_list_t **l, int elements){ if (!s->first) return ABORT(e_underflow); if (s->first->t != a_atom_pointer) ABORT(e_type); pf_atom_t *a = s->first->w.w_atom_pointer; if (!a) ABORT (e_pointer); if (!(pf_atom_islist(a))) ABORT(e_type); *l = a->w.w_list; if (!(*l)) ABORT(e_internal); if ((*l)->elements < elements) ABORT(e_underflow); pf_stack_drop(s); EXIT; } static void getlistptr(pf_vm_t *vm, pf_stack_t *s, pf_list_t **l){ getlistptr_size(vm, s, l, 0); } // indirect list ops: for implementing queues and stacks // ( el plist -- ) PF_PRIMITIVE(pf_forthword_plist_push){ pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); CHECKN(1); pf_list_push_atom(l, pf_list_pop_atom(vm->data_stack)); EXIT; } PF_PRIMITIVE(pf_forthword_plist_queue){ pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); CHECKN(1); pf_list_queue_atom(l, pf_list_pop_atom(vm->data_stack)); EXIT; } PF_PRIMITIVE(pf_forthword_plist_pop){ pf_error_t e; pf_list_t *l = 0; getlistptr_size(vm, vm->data_stack, &l, 1); pf_list_push_atom(vm->data_stack, pf_list_pop_atom(l)); EXIT; } PF_PRIMITIVE(pf_forthword_plist_head){ pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); pf_list_push_atom_pointer(vm->data_stack, l->first); EXIT; } PF_PRIMITIVE(pf_forthword_plist_tail){ pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); pf_list_push_atom_pointer(vm->data_stack, l->last); EXIT; } // (el n plist -- ) PF_PRIMITIVE(pf_forthword_plist_insert){ pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); CHECKN(2); CHECK1(a_int); int n = ARG0->w.w_int; if ((n < 0) || (n > l->elements)) ABORT (e_inval); DROP1; pf_list_insert_atom(l, n, pf_list_pop_atom(vm->data_stack)); EXIT; } // truncate a stack // can be used for ds too PF_PRIMITIVE(pf_forthword_plist_trunc){ CHECKN(2); pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); int n = INT(ARG0); DROP1; while (n < l->elements) pf_stack_drop(l); while (n > l->elements) pf_list_push(l, a_undef, (pf_word_t)0); EXIT; } static int atom_equal(pf_atom_t *a, pf_atom_t *b){ return ((a->t == b->t) && (a->w.w_int == b->w.w_int)); } PF_PRIMITIVE(pf_forthword_plist_contains){ pf_error_t e; pf_list_t *l; int result = 0; getlistptr(vm, vm->data_stack, &l); pf_atom_t *thing = pf_list_pop_atom(vm->data_stack); // get thing to search pf_atom_t *a = l->first; while (a){ if (atom_equal(thing, a)) { result = -1; goto done; } a = a->next; } done: pf_stackatom_drop(thing); PUSH_INT(result); EXIT; } PF_PRIMITIVE(pf_forthword_plist_remove){ pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); if (!(l->elements)) ABORT(e_underflow); pf_atom_t *thing = pf_list_pop_atom(vm->data_stack); // get thing to remove pf_atom_t *a = l->first; // first element? if (atom_equal(a, thing)){ pf_stack_drop(l); e = e_ok; goto done; } // other element else{ while (a->next){ if (atom_equal(a->next, thing)){ pf_atom_t *removed = a->next; a->next = removed->next; l->elements--; if (l->last == removed) l->last = a; pf_stackatom_drop(removed); e = e_ok; goto done; } a = a->next; } } // not found e = e_inval; done: pf_stackatom_drop(thing); if (e) ABORT (e); EXIT; } PF_PRIMITIVE(pf_forthword_plist_atfind){ // lookup something in a list CHECK2(a_atom_pointer, a_symbol); if (ARG0->w.w_atom_pointer->t != a_list) ABORT(e_type); pf_list_t *l = ARG0->w.w_atom_pointer->w.w_list; pf_atom_t *a = l->first; while (a){ if (a->t != a_list) ABORT(e_type); pf_atom_t *first = a->w.w_list->first; if (first->t != a_symbol) ABORT(e_type); if (ARG1->w.w_symbol == first->w.w_symbol){ DROP1; DROP1; pf_list_push_atom_pointer(vm->data_stack, first->next); EXIT; } a = a->next; } ABORT (e_undef); } PF_PRIMITIVE(pf_forthword_plist_resize){ // i.e. for delay lines ( size plist -- ) pf_error_t e; pf_list_t *l = 0; getlistptr(vm, vm->data_stack, &l); CHECK1(a_int); int size = pf_list_pop(vm->data_stack).w_int; if (size < 0) size = 0; if (l->elements == 0) pf_list_push(l, a_undef, (pf_word_t)0); while (size < l->elements) {pf_stack_drop(l);} while (size > l->elements) {pf_stack_dup(l);} EXIT; } // direct list ops (list on data stack) // ( list el -- newlist ) PF_PRIMITIVE(pf_forthword_list_push) { pf_list_t *l; CHECKN(2); if (!(pf_atom_islist(ARG1))) ABORT(e_type); l = ARG1->w.w_list; pf_list_push_atom(l, pf_list_pop_atom(vm->data_stack)); EXIT; } PF_PRIMITIVE(pf_forthword_list_queue) { pf_list_t *l; CHECKN(2); if (!(pf_atom_islist(ARG1))) ABORT(e_type); l = ARG1->w.w_list; pf_list_queue_atom(l, pf_list_pop_atom(vm->data_stack)); EXIT; } PF_PRIMITIVE(pf_forthword_list_pop) { pf_list_t *l; CHECKN(1); if (!(pf_atom_islist(ARG0))) ABORT(e_type); l = ARG0->w.w_list; if (!l->first) ABORT(e_underflow); pf_list_push_atom(vm->data_stack, pf_list_pop_atom(l)); EXIT; } PF_PRIMITIVE(pf_forthword_list_join) { pf_atom_t *a; pf_list_t *l; CHECKN(2); int list_right = pf_atom_islist(ARG0); int list_left = pf_atom_islist(ARG1); int flag = ((list_left & 1) << 1) | (list_right & 1); switch(flag){ case 0: // (nolist nolist) ABORT(e_type); case 1: // (nolist list) l = pf_list_pop(vm->data_stack).w_list; pf_list_push_atom(l, pf_list_pop_atom(vm->data_stack)); PUSH_LIST(l); EXIT; case 2: // (list nolist) a = pf_list_pop_atom(vm->data_stack); pf_list_queue_atom(ARG0->w.w_list, a); EXIT; case 3: // (list list) l = pf_list_pop(vm->data_stack).w_list; pf_list_join(ARG0->w.w_list, l); EXIT; } EXIT; } PF_PRIMITIVE(pf_forthword_list_size) { CHECKN(1); pf_atom_t *a = ARG0; // if (a->t == a_atom_pointer) a = a->w.w_atom_pointer; // deref if (!(pf_atom_islist(a))) ABORT(e_type); pf_list_push(vm->data_stack, a_int, (pf_word_t)a->w.w_list->elements); EXIT; } // transpose a list of lists PF_PRIMITIVE(pf_forthword_list_transpose) { int n; CHECK1(a_list); pf_list_t *container = ARG0->w.w_list; PF_STACK_CHECK1(container, a_list); n = container->first->w.w_list->elements; /* check input container structure */ pf_atom_t *a = container->first; for (a=container->first;a;a=a->next){ if (a->t != a_list) ABORT(e_type); if (a->w.w_list->elements != n) ABORT (e_inval); } /* create output container */ pf_list_t *out_container = pf_list_new(); while (n--){ pf_list_t *l = pf_list_new(); for (a=container->first;a;a=a->next){ pf_list_queue_atom(l, pf_list_pop_atom(a->w.w_list)); } pf_list_queue_list(out_container, l); } /* cleanup */ pf_tree_free(container); ARG0->w.w_list = out_container; EXIT; } static inline void swapatom(pf_atom_t *a, pf_atom_t *b) { pf_word_type_t t; int i; t = a->t; i = a->w.w_int; a->t = b->t; a->w.w_int = b->w.w_int; b->t = t; b->w.w_int = i; } /* faculty base encoding: digit 2! -> last pick digit 3! -> second last ... */ void get_permutation(int *perm, int coefs, int number) { int base = 2; while(coefs--){ *perm++ = number % base; number /= base; base++; } } /* permute using faculty base encoded permutations */ PF_PRIMITIVE(pf_forthword_list_permute) { CHECK2(a_int, a_list); int number = pf_list_pop(vm->data_stack).w_int; if (number < 0) number = 0; pf_list_t *l = ARG0->w.w_list; int coefs = l->elements - 1; if (coefs < 0) EXIT; int perm[coefs]; get_permutation(perm, coefs, number); int i = coefs-1; pf_atom_t *a = l->first; while (i >= 0){ pf_atom_t *b = a; int n = perm[i]; //pf_post("n = %d", n); while (n--){ PF_ASSERT(b); b = b->next; } PF_ASSERT(b); swapatom(a, b); a = a->next; i--; } EXIT; } PF_PRIMITIVE(pf_forthword_list_randompermute) { int i, range; pf_list_t *l; pf_atom_t *a, *b; CHECKN(1); if (!(pf_atom_islist(ARG0))) ABORT(e_type); l = ARG0->w.w_list; if (l->elements <= 1) EXIT; /* randomly swap each element from (0:i) with one from (i+1:l-1) */ a = l->first; // target atom range = l->elements - 1; // range of possible swap targets for (i=0; ielements-1; i++){ int r = rand() % range; b = a->next; while (r--) b=b->next; swapatom(a,b); a = a->next; range--; } EXIT; } // indexed list access ( list n - list l[n] ) PF_PRIMITIVE(pf_forthword_list_index){ pf_atom_t *a; int n; CHECK2(a_int, a_list); a = ARG1->w.w_list->first; n = ARG0->w.w_int; while (n--){ if (!a) ABORT (e_list); a = a->next; } if (!a) ABORT (e_list); DROP1; pf_stack_push_atom(vm->data_stack, a); EXIT; } // reverse a list PF_PRIMITIVE(pf_forthword_list_reverse){ pf_atom_t *a; int n; CHECK1(a_list); pf_list_reverse(ARG0->w.w_list); EXIT; } PF_PRIMITIVE(pf_forthword_atom_follow){ pf_atom_t *a; CHECK1(a_atom_pointer); a = ARG0->w.w_atom_pointer; if (!a || pf_atom_stale(a)) THROW(e_pointer, "following NULL variable (end of atom list?)"); ARG0->w.w_atom_pointer = a->next; EXIT; } /* conversion methods. they convert TOS to the specified type. they use the type specific pops to do this */ /* convert to int */ PF_PRIMITIVE(pf_forthword_int) { int i; char *string; if (!ARG0) ABORT(e_underflow); switch(ARG0->t){ default: ABORT(e_type); case a_int: EXIT; case a_float: ARG0->t = a_int; ARG0->w.w_int = (int)ARG0->w.w_float; EXIT; case a_packet: string = STRING(ARG0); if (!string) ABORT(e_type); else { i = strtol(string, 0, 0); DROP1; PUSH_INT(i); EXIT; } } } /* convert to float */ PF_PRIMITIVE(pf_forthword_float) { float f; char *string; if (!ARG0) ABORT(e_underflow); switch(ARG0->t){ default: ABORT(e_type); case a_float: EXIT; case a_int: ARG0->t = a_float; ARG0->w.w_float = (float)ARG0->w.w_int; EXIT; case a_packet: string = STRING(ARG0); if (!string) ABORT(e_type); else { f = strtod(string, 0); DROP1; PUSH_FLOAT(f); EXIT; } } } /* convert raw atom to pointer: use with care */ PF_PRIMITIVE(pf_forthword_pointer) { if (!ARG0) ABORT(e_underflow); ARG0->t = a_pointer; EXIT; } /* convert a string to a symbol */ PF_PRIMITIVE(pf_forthword_symbol) { CHECK1(a_packet); char *string = STRING(ARG0); if (!string) ABORT(e_type); pf_symbol_t *sym = pf_symbol(string); DROP1; PUSH_SYMBOL(sym); EXIT; } /* convert a string to a symbol */ PF_PRIMITIVE(pf_forthword_symbolsize) { CHECK1(a_symbol); PUSH_INT(strlen(ARG0->w.w_symbol->s_name)); EXIT; } /* convert anything to string */ PF_PRIMITIVE(pf_forthword_string) { char *c; pf_packet_t p; pf_atom_t *a; CHECKN(1); if (!ARG0) ABORT(e_underflow); a = ARG0; switch(a->t){ case a_packet: // is it already a string ? c = pf_packet_string_data(a->w.w_packet); if (!c) ABORT(e_type); else EXIT; case a_symbol: p = pf_packet_stringf("%s", a->w.w_symbol->s_name); goto replace; case a_float: p = pf_packet_stringf("%.2f", a->w.w_float); goto replace; case a_int: p = pf_packet_stringf("%d", a->w.w_int); goto replace; default: break; } ABORT(e_type); // fallthrough replace: DROP1; PUSH_PACKET(p); EXIT; } #include #include /* seed random number generator based on current time */ PF_PRIMITIVE(pf_forthword_seed){ struct timeval tv; gettimeofday(&tv, 0); unsigned int seed = tv.tv_usec; srand(seed); EXIT; } /* random integer with range 0 .. TOS-1 */ PF_PRIMITIVE(pf_forthword_rand) { unsigned int r = rand(); if (!ARG0) ABORT(e_underflow); switch(ARG0->t){ default: ABORT(e_type); case a_int: ARG0->w.w_int = r % ARG0->w.w_int; EXIT; case a_float: ARG0->w.w_float *= (float)r / (float)RAND_MAX; EXIT; } } /* get a 2 floats from a normal distribution */ PF_PRIMITIVE(pf_forthword_2normal) { float a = ((float)rand()) * (2.0f * M_PI * (1.0f / ((float)RAND_MAX))); float r = ((float)(1 + rand())) * (1.0f / ((float)RAND_MAX)); float x = cos(a); float y = sin(a); r = sqrt(-2.0f * log(r)); PUSH_FLOAT(x*r); PUSH_FLOAT(y*r); EXIT; } /* something i changed after being very annoyed by it.. int int -> int int float -> float float int -> float float float -> float the first one is the standard int one, needs to be the first one that's tried in the polyword! the second one accepts floats. this results in 2 checking / converting routines */ static void int_to_float(pf_atom_t *a){ if (a->t == a_int){ a->w.w_float = (float)a->w.w_int; a->t = a_float; } } PF_PRIMITIVE(pf_forthword_1op_int){ CHECK1(a_int); EXIT; } PF_PRIMITIVE(pf_forthword_1op_float){ CHECKN(1); int_to_float(ARG0); CHECK1(a_float); EXIT; } PF_PRIMITIVE(pf_forthword_2op_int){ CHECK2(a_int, a_int); EXIT; } PF_PRIMITIVE(pf_forthword_2op_float){ CHECKN(2); int_to_float(ARG0); int_to_float(ARG1); CHECK2(a_float, a_float); EXIT; } /* type specific stuff these need to check for stack AND type errors */ #define get_float(arg) ({float f = FLOAT(arg); f;}) #define get_int(arg) ({int i = INT(arg); i;}) #define OP1(name, type, op) \ PF_PRIMITIVE(pf_forthword_##name##_##type) \ { \ CHECKN(1); \ ARG0->w.w_##type = op (get_##type(ARG0)); \ EXIT; \ } int intfloat(pf_atom_t *arg0, pf_atom_t *arg1){ if ((arg0->t == a_int) &&(arg1->t == a_float)) { arg0->w.w_float = (float)arg0->w.w_int; arg0->t = a_float; return 1; } return 0; } void cast_2op (pf_vm_t *vm){ CHECKN(2); if (ARG0->t == ARG1->t) EXIT; if (!(intfloat(ARG0,ARG1) ||intfloat(ARG1,ARG0))) {ABORT(e_type);} EXIT; } #define CHECK_2OP cast_2op(vm) #define OP2(name, type, op) \ PF_PRIMITIVE(pf_forthword_##name##_##type) \ { \ CHECK_2OP; \ type result = get_##type(ARG1) op get_##type(ARG0); \ DROP1; \ ARG0->w.w_##type = result; \ EXIT; \ } // conditional assignment #define pop_float ({float f = FLOAT(ARG0); DROP1; f;}) #define pop_int ({int f = INT(ARG0); DROP1; f;}) #define OPCA(name, type, op) \ PF_PRIMITIVE(pf_forthword_##name##_##type) \ { \ CHECK_2OP; \ type x0 = get_##type(ARG0); \ type x1 = get_##type(ARG1); \ type result = x1 op x0 ? x1 : x0; \ DROP1; \ ARG0->w.w_##type = result; \ EXIT; \ } #define OP2COMP(name, type, op) \ PF_PRIMITIVE(pf_forthword_##name##_##type) \ { \ CHECK_2OP; \ type x0 = get_##type(ARG0); \ type x1 = get_##type(ARG1); \ int result = x1 op x0 ? -1 : 0; \ DROP1; \ ARG0->t = a_int ; \ ARG0->w.w_int = result; \ EXIT; \ } static float inverse(float f){return 1.0f / f;} // float and int OPCA(max, float, >); OPCA(min, float, <); OP1(abs, float, fabs); OPCA(max, int, >); OPCA(min, int, <); OP2COMP(gt, int, >); OP2COMP(gte, int, >=); OP2COMP(lt, int, <); OP2COMP(lte, int, <=); OP2COMP(gt, float, >); OP2COMP(gte, float, >=); OP2COMP(lt, float, <); OP2COMP(lte, float, <=); OP1(abs, int, abs); OP2(add, float, +); OP2(sub, float, -); OP2(mul, float, *); OP2(div, float, /); OP2(add, int, +); OP2(sub, int, -); OP2(mul, int, *); OP2(div, int, /); // float only OP1(inverse, float, inverse); OP1(sqrt, float, sqrt); OP1(sin, float, sin); OP1(asin, float, asin); OP1(cos, float, cos); OP1(acos, float, acos); OP1(exp, float, exp); OP1(log, float, log); OP1(tan, float, tan); OP1(atan, float, atan); // int only OP2(shl, int, <<); OP2(shr, int, >>); OP2(and, int, &); OP2(or, int, |); OP2(xor, int, ^); OP1(not, int, !); /* special int ops */ PF_PRIMITIVE(pf_forthword_ilog2) { CHECK1(a_int); int i = ARG0->w.w_int; int l = -1; if (i < 1) ABORT (e_inval); while(i){ i >>= 1; l++; } ARG0->w.w_int = l; EXIT; } PF_PRIMITIVE(pf_forthword_iexp2) { CHECK1(a_int); int l = ARG0->w.w_int; int i = 1; if (l < 0) ABORT (e_inval); while(l){ i <<= 1; l--; } ARG0->w.w_int = i; EXIT; } /* int and float math */ PF_PRIMITIVE(pf_forthword_fixedpoint){ CHECK1(a_float); float f = ARG0->w.w_float; int shift = 0; while (fabs(f) > 1.0f) { f *= 0.5f; shift++; } ARG0->w.w_float = f; PUSH_INT(shift); EXIT; } PF_PRIMITIVE(pf_forthword_mod_int){ CHECKN(2); int x0 = INT(ARG0); int x1 = INT(ARG1); int retval = (x1 % x0); if (retval < 0) retval += x0; DROP2; pf_list_push_int (vm->data_stack, retval); EXIT; } PF_PRIMITIVE(pf_forthword_mod_float){ CHECKN(2); float x0 = FLOAT(ARG0); float x1 = FLOAT(ARG1); float quot = x1 / x0; int iquot = (int)quot; float retval = x1 - x0 * ((float)iquot); if (retval < 0) retval += x0; DROP2; pf_list_push_float (vm->data_stack, retval); EXIT; } /* FIXME: sawtooth modulo this can serve to implement ping-pong wraparound */ PF_PRIMITIVE(pf_forthword_mirror_float){ CHECKN(2); float x0 = FLOAT(ARG0); float x1 = FLOAT(ARG1); float quot = x1 / x0; int iquot = (int)quot; float retval = x1 - x0 * ((float)iquot); if (retval < 0){ retval += x0; iquot += 1; } if (iquot & 1) retval = x0 - retval; DROP2; pf_list_push_float (vm->data_stack, retval); EXIT; } /* /\* hashes *\/ */ /* PF_PRIMITIVE(pf_forthword_hash_test) */ /* { */ /* CHECK2(a_int, a_list); */ /* int logsize = pf_list_pop(vm->data_stack).w_int; */ /* pf_list_t *l = pf_list_pop(vm->data_stack).w_list; */ /* pf_hash_t *h = pf_hash_new(logsize); */ /* int i = 0; */ /* while (l->elements){ */ /* pf_atom_t *a=pf_list_pop_atom(l); */ /* PF_ASSERT(a->t == a_symbol); */ /* pf_symbol_t *s = a->w.w_symbol; */ /* a->t = a_int; */ /* a->w.w_int = 123; */ /* pf_hash_add(h, s, a); */ /* } */ /* i = 1 << (h->logsize); */ /* while (i--){ */ /* pf_post("%d ", h->table[i]->elements / 2); */ /* } */ /* pf_hash_free(h); */ /* pf_list_free(l); */ /* EXIT; */ /* } */ /* load undefined atom */ PF_PRIMITIVE(pf_forthword_push_undef) { pf_list_push(vm->data_stack, a_undef, (pf_word_t)0); EXIT; } /* load null pointer */ PF_PRIMITIVE(pf_forthword_push_null) { pf_list_push(vm->data_stack, a_atom_pointer, (pf_word_t)0); EXIT; } /* some packet words */ PF_PRIMITIVE(pf_forthword_push_invalid_packet) { PUSH_PACKET(-1); EXIT; } /* is invalid packet == is packet and is invalid */ // FIXME: take this out, make sure invalid packets never make it to forth PF_PRIMITIVE(pf_forthword_is_invalid_packet) { CHECKN(1); if (ARG0->t == a_packet && (!ARG0->w.w_packet)) { PUSH_INT(1); } else { PUSH_INT(0); } EXIT; } /* is invalid packet == is packet and is invalid */ PF_PRIMITIVE(pf_forthword_is_string) { CHECKN(1); if (ARG0->t != a_packet) { PUSH_INT(0); } else if (!pf_packet_string_data(ARG0->w.w_packet)) { PUSH_INT(0); } else { PUSH_INT(1); } EXIT; } /* create a new packet using the type symbol in TOS actually, it doesn't really make sense to do this in highlevel forth code, since packets will be uninitialized.. NOTE: creating string packets will return an empty string and using that will crash the system. */ PF_PRIMITIVE(pf_forthword_new_packet) { pf_symbol_t *type; pf_atom_t *a = ARG0; pf_packet_t p = 0; if (!ARG0) ABORT(e_underflow); if (ARG0->t == a_list){ type = pf_typesymbol_from_list(ARG0->w.w_list); } else if (ARG0->t == a_symbol){ type = a->w.w_symbol; } p = pf_factory_newpacket(type); if (!p){ THROW(e_inval, "can't create packet of type %s", type->s_name); } DROP1; PUSH_PACKET(p); EXIT; } #if 0 PF_PRIMITIVE(pf_forthword_convert_packet) { pf_symbol_t *type; int packet; pf_atom_t *a = ARG0; CHECKN(2); if (ARG1->t != a_packet) ABORT(e_type); packet = ARG1->w.w_packet; if (ARG0->t == a_list){ type = pf_typelist_to_typesymbol(ARG0->w.w_list); } else if (ARG0->t == a_symbol){ type = a->w.w_symbol; } DROP1; packet = pf_packet_convert(packet, type); DROP1; PUSH_PACKET(packet); EXIT; } #endif /* replace packet with clone. for other types equivalent to dup. */ PF_PRIMITIVE(pf_forthword_packet_clone) { if (!ARG0) ABORT(e_underflow); if (ARG0->t != a_packet) // if not packet -> delegate to dup { _TRY(pf_stack_dup(vm->data_stack)); } PUSH_PACKET(pf_packet_clone(ARG0->w.w_packet)); EXIT; } /* push mime type (description) */ PF_PRIMITIVE(pf_forthword_packet_mime_list) { pf_list_t *type; pf_header_t *header; CHECK1(a_packet); header = pf_packet_header(ARG0->w.w_packet); if (header) { PUSH_LIST(pf_list_from_typesymbol(pf_packet_type(header))); } else { PUSH_LIST(pf_list_new()); } EXIT; } /* the = operator */ PF_PRIMITIVE(pf_forthword_equals) { int flag; CHECKN(2); if (ARG0->t != ARG1->t){ // this used to be an error, but comparing // different types really should return non-equal flag = 0; } else { flag = (ARG0->w.w_int == ARG1->w.w_int) ? -1 : 0; switch (ARG0->t){ /* basic types : need to match bit by bit */ case a_int: case a_pointer: case a_atom_pointer: case a_symbol: case a_error: break; case a_undef: /* undefined: don't care about contents of word */ flag = -1; break; /* packets need to be handled elsewhere if they are not*/ case a_packet: if (!flag) ABORT(e_type); // another comparator (polyword) should handle break; case a_list: // not supported here default: ABORT(e_type); // other types need to override this operator } } done: DROP1; DROP1; PUSH_INT(flag); EXIT; } /* push TOS's type on stack */ PF_PRIMITIVE(pf_forthword_type) { if (vm->data_stack->elements < 1) ABORT(e_underflow); PUSH_SYMBOL(pf_atom_typesymbol(ARG0)); EXIT; } /* nop */ PF_PRIMITIVE(pf_forthword_nop){EXIT;} /* nop */ PF_PRIMITIVE(pf_forthword_to_xt){ CHECKN(1); switch(ARG0->t){ case a_atom_pointer: ARG0->t = a_forth_xt; EXIT; default: ABORT(e_type); } } PF_PRIMITIVE(pf_string){ PUSH_PACKET(pf_packet_string_buffer(10)); //FIXME: arbitrary EXIT; } /* reserve packet : make mutable */ /* PF_PRIMITIVE(pf_forthword_reserve){ */ /* CHECK1(a_packet); */ /* pf_packet_t p = pf_packet_reserve(&ARG0->w.w_packet); */ /* if (!p){ */ /* pf_header_t *h = pf_packet_header(ARG0->w.w_packet); */ /* THROW(e_inval, "cannot copy packets of type %s", h->desc->s_name); */ /* } */ /* EXIT; */ /* } */ /* SETUP CODE */ /* local init */ static void _forth_word(char *name, pf_forth_primitive_t word){ pf_vm_add_primitive(pf_forth_vm(), pf_symbol(name), word); } static void _poly_word(char* polyname, char *name, pf_forth_primitive_t word){ _forth_word(name, word); //pf_vm_add_to_polyword(pf_forth_vm, pf_symbol(polyname), word); // CLEANUP LATER WHILE ADDING DOC STRINGS } #define REGISTER_PRIMITIVE PF_REGISTER_FUNCTION #define FIXME_REG_PRIM(x,y) REGISTER_PRIMITIVE(y,x,"") void pf_forth_basic(void) { pf_vm_t *vm = pf_forth_vm(); /* general purpose stack words */ REGISTER_PRIMITIVE(pf_forthword_dup, "dup", "( a -- a a )\tDuplicate item."); REGISTER_PRIMITIVE(pf_forthword_swap, "swap", "( a b -- b a)\tExchange 2 top items."); REGISTER_PRIMITIVE(pf_forthword_drop, "drop", "( a -- )\tDiscard top item."); REGISTER_PRIMITIVE(pf_forthword_over, "over", "( a b -- a b a )\tDuplicate 2nd item."); REGISTER_PRIMITIVE(pf_forthword_pick, "pick", "( index -- thing )\tIndexed data stack access. Avoid using this."); REGISTER_PRIMITIVE(pf_string, "string", "( -- string )\tCreate a new string."); /* indirect list ops. */ REGISTER_PRIMITIVE(pf_forthword_plist_remove, "remove", "( thing listvar -- )\tRemove a thing from a list."); REGISTER_PRIMITIVE(pf_forthword_plist_contains, "contains?", "( thing listvar -- ? )\tDoes list contain element?"); REGISTER_PRIMITIVE(pf_forthword_plist_insert, "insert", "( thing position listvar -- )\tInsert thing in list contained in variable."); REGISTER_PRIMITIVE(pf_forthword_plist_push, "push", "( thing listvar -- )\tPush thing to list contained in variable. Inserts before the head of the list."); REGISTER_PRIMITIVE(pf_forthword_plist_queue, "queue", "( thing listvar -- )\tEnqueue thing in list in varable. Appends after the tail of the list."); REGISTER_PRIMITIVE(pf_forthword_plist_pop, "pop", "( listvar -- thing )\tPop a thing from a list in a variable. Removes the head of the list."); REGISTER_PRIMITIVE(pf_forthword_plist_head, "head", "( listvar -- headvar )\tGet a pointer to the first element of a list."); REGISTER_PRIMITIVE(pf_forthword_plist_tail, "tail", "( listvar -- tailvar )\tGet a pointer to the last element of a list."); REGISTER_PRIMITIVE(pf_forthword_plist_atfind, "@find", "( listvar -- var )\tSearch a double list and return variable."); REGISTER_PRIMITIVE(pf_forthword_plist_trunc, "trunc", "( size listvar -- )\tResize a list in variable (truncate / expand)."); REGISTER_PRIMITIVE(pf_forthword_plist_resize, "queue-size!", "( size listvar -- )\tResize a list in variable by either 'dup' or 'drop' ops. Empty list will contain 'undef'. Mainly for delay lines."); /* direct list ops */ REGISTER_PRIMITIVE(pf_forthword_pack, "list:pack", "( ... n -- list )\tPack n elements into list."); REGISTER_PRIMITIVE(pf_forthword_unpack, "list:unpack", "( list -- ... )\tUnpack list elements."); REGISTER_PRIMITIVE(pf_forthword_list_reverse, "list:reverse", "( list -- list )\tReverse the order of the elements in a list."); REGISTER_PRIMITIVE(pf_forthword_list_randompermute, "list:shuffle", "( list -- list )\tPerform a random permutation of the elements in a list."); REGISTER_PRIMITIVE(pf_forthword_list_permute, "list:perm", "( permid list -- list)\tPermute elements in a list. The permid is an (abstract) permutation id."); REGISTER_PRIMITIVE(pf_forthword_list_transpose, "list:transpose", "( list -- list )\tChange inner/outer dimensions for a 2D list structure."); REGISTER_PRIMITIVE(pf_forthword_list_size, "list:size", "( list -- list size )\tReturn the number of elements in a list."); REGISTER_PRIMITIVE(pf_forthword_atom_follow, "follow", "( atompointer -- atompointer )\tChase a pointer. (for list traversal)."); REGISTER_PRIMITIVE(pf_forthword_list_join, "list:concat", "( list list/atom -- list )\tConatenate lists and/or atoms."); /* packet ops */ // REGISTER_PRIMITIVE(pf_forthword_reserve, "reserve", "( packet -- packet )\tReserve a packet. This makes a private copy if necessary (for muting operations)."); REGISTER_PRIMITIVE(pf_forthword_push_invalid_packet, "ip", "( -- packet)\tGet an invalid packet."); REGISTER_PRIMITIVE(pf_forthword_is_invalid_packet, "ip?", "( packet -- packet ? )\tIs packet invalid?."); REGISTER_PRIMITIVE(pf_forthword_is_string, "string?", "( thing -- thing ? )\tIs thing a string?."); REGISTER_PRIMITIVE(pf_forthword_new_packet, "new", "( typelist/symbol -- packet )\tCreate a new packet."); REGISTER_PRIMITIVE(pf_forthword_packet_clone, "clone", "( packet -- packet packet )\tClone a packet."); /* types */ REGISTER_PRIMITIVE(pf_forthword_type, "type", "( thing -- thing type )\tGet type symbol."); REGISTER_PRIMITIVE(pf_forthword_packet_mime_list, "typelist", "( packet -- packet list )\tGet type description list."); /* misc */ REGISTER_PRIMITIVE(pf_forthword_nop, "nop", "( -- )\tDo nothing."); REGISTER_PRIMITIVE(pf_forthword_push_undef, "undef", "( -- undef )\tLoad undefined value."); REGISTER_PRIMITIVE(pf_forthword_push_null, "null", "( -- null )\tLoad null pointer."); REGISTER_PRIMITIVE(pf_forthword_to_xt, ">xt", "( thing -- xt )\tConvert thing to xt."); /* type converters (casts) */ REGISTER_PRIMITIVE(pf_forthword_int, "scalar>int", "( scalar -- int )\tConvert a scalar value to an integer."); REGISTER_PRIMITIVE(pf_forthword_float, "scalar>float", "( scalar -- float )\tConvert a scalar value to a float."); REGISTER_PRIMITIVE(pf_forthword_pointer,"scalar>pointer", "( scalar -- pointer )\tConvert a scalar value to a void pointer."); REGISTER_PRIMITIVE(pf_forthword_string, "scalar>string", "( scalar -- string )\tConvert a scalar value to a string."); REGISTER_PRIMITIVE(pf_forthword_symbol, "scalar>symbol", "( scalar -- symbol )\tConvert a scalar value to a symbol."); /* random numbers */ REGISTER_PRIMITIVE(pf_forthword_seed, "seed", "( -- )\tSeed random number generator based on current system time."); REGISTER_PRIMITIVE(pf_forthword_rand, "rand", "( max -- float )\tDraw a number from a uniform [0..max] distribution."); REGISTER_PRIMITIVE(pf_forthword_2normal, "2normal", "( -- float float )\tDraw 2 numbers from a normal distribution (avg = 0, stdev = 1)"); /* comparison */ REGISTER_PRIMITIVE(pf_forthword_gt_float, "float:>", ""); REGISTER_PRIMITIVE(pf_forthword_lt_float, "float:<", ""); REGISTER_PRIMITIVE(pf_forthword_gte_float, "float:>=", ""); REGISTER_PRIMITIVE(pf_forthword_lte_float, "float:<=", ""); REGISTER_PRIMITIVE(pf_forthword_gt_int, "int:>", ""); REGISTER_PRIMITIVE(pf_forthword_lt_int, "int:<", ""); REGISTER_PRIMITIVE(pf_forthword_gte_int, "int:>=", ""); REGISTER_PRIMITIVE(pf_forthword_lte_int, "int:<=", ""); /* floating point ops */ REGISTER_PRIMITIVE(pf_forthword_add_float, "float:+", ""); REGISTER_PRIMITIVE(pf_forthword_sub_float, "float:-", ""); REGISTER_PRIMITIVE(pf_forthword_mul_float, "float:*", ""); REGISTER_PRIMITIVE(pf_forthword_div_float, "float:/", ""); REGISTER_PRIMITIVE(pf_forthword_mirror_float, "float:mirror", ""); REGISTER_PRIMITIVE(pf_forthword_mod_float, "float:mod", ""); REGISTER_PRIMITIVE(pf_forthword_mod_float, "float:%", ""); REGISTER_PRIMITIVE(pf_forthword_min_float, "float:min", ""); REGISTER_PRIMITIVE(pf_forthword_max_float, "float:max", ""); REGISTER_PRIMITIVE(pf_forthword_inverse_float, "float:inverse", ""); REGISTER_PRIMITIVE(pf_forthword_sin_float, "float:sin", ""); REGISTER_PRIMITIVE(pf_forthword_abs_float, "float:abs", ""); REGISTER_PRIMITIVE(pf_forthword_sqrt_float, "float:sqrt", ""); REGISTER_PRIMITIVE(pf_forthword_cos_float, "float:cos", ""); REGISTER_PRIMITIVE(pf_forthword_exp_float, "float:exp", ""); REGISTER_PRIMITIVE(pf_forthword_log_float, "float:log", ""); REGISTER_PRIMITIVE(pf_forthword_tan_float, "float:tan", ""); REGISTER_PRIMITIVE(pf_forthword_atan_float,"float:atan", ""); REGISTER_PRIMITIVE(pf_forthword_acos_float, "float:acos", ""); REGISTER_PRIMITIVE(pf_forthword_asin_float, "float:asin", ""); /* integer ops */ FIXME_REG_PRIM("int:+", pf_forthword_add_int); FIXME_REG_PRIM("int:-", pf_forthword_sub_int); FIXME_REG_PRIM("int:*", pf_forthword_mul_int); FIXME_REG_PRIM("int:/", pf_forthword_div_int); FIXME_REG_PRIM("int:mod", pf_forthword_mod_int); FIXME_REG_PRIM("int:%", pf_forthword_mod_int); FIXME_REG_PRIM("int:<<", pf_forthword_shl_int); FIXME_REG_PRIM("int:>>", pf_forthword_shr_int); FIXME_REG_PRIM("int:and", pf_forthword_and_int); FIXME_REG_PRIM("int:or", pf_forthword_or_int); FIXME_REG_PRIM("int:xor", pf_forthword_xor_int); FIXME_REG_PRIM("int:not", pf_forthword_not_int); FIXME_REG_PRIM("int:abs", pf_forthword_abs_int); FIXME_REG_PRIM("int:min", pf_forthword_min_int); FIXME_REG_PRIM("int:max", pf_forthword_max_int); FIXME_REG_PRIM("int:log2", pf_forthword_ilog2); FIXME_REG_PRIM("int:exp2", pf_forthword_iexp2); FIXME_REG_PRIM("float:fixedpoint", pf_forthword_fixedpoint); FIXME_REG_PRIM("scalar:=", pf_forthword_equals); FIXME_REG_PRIM("symbol:size", pf_forthword_symbolsize); /* hash */ // FIXME_REG_PRIM("hashtest",pf_forthword_hash_test); }