From 37b6643df2df7d784a31ca73f7bb90dc109c2401 Mon Sep 17 00:00:00 2001 From: Hans-Christoph Steiner Date: Thu, 15 Dec 2005 07:26:47 +0000 Subject: removing PDP source (except debian files) before import of PDP 0.12.4 svn path=/trunk/externals/pdp/; revision=4217 --- system/kernel/pdp_forth.c | 541 ---------------------------------------------- 1 file changed, 541 deletions(-) delete mode 100644 system/kernel/pdp_forth.c (limited to 'system/kernel/pdp_forth.c') diff --git a/system/kernel/pdp_forth.c b/system/kernel/pdp_forth.c deleted file mode 100644 index 1764004..0000000 --- a/system/kernel/pdp_forth.c +++ /dev/null @@ -1,541 +0,0 @@ -/* - * Pure Data Packet header file. Packet processor system - * 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 "pdp.h" -#include "pdp_forth.h" - -#define D if (0) - - - -t_pdp_stack *pdp_stack_new(void) {return pdp_list_new(0);} - -void pdp_stack_free(t_pdp_stack *s) { - pdp_tree_strip_packets(s); - pdp_list_free(s); -} - - -/* some stack manips */ -t_pdp_word_error pdp_stack_dup(t_pdp_stack *s) -{ - if (!s->first) return e_underflow; - pdp_list_add(s, s->first->t, s->first->w); - - /* copy it properly if its a packet */ - if (s->first->t == a_packet){ - s->first->w.w_packet = pdp_packet_copy_ro(s->first->w.w_packet); - } - return e_ok; -} - -t_pdp_word_error pdp_stack_drop(t_pdp_stack *s) -{ - if (!s->first) return e_underflow; - - /* delete it properly if its a packet */ - if (s->first->t == a_packet){ - pdp_packet_mark_unused(s->first->w.w_packet); - } - pdp_list_pop(s); - - return e_ok; -} - -t_pdp_word_error pdp_stack_over(t_pdp_stack *s) -{ - if (s->elements < 2) return e_underflow; - pdp_list_add(s, s->first->next->t, s->first->next->w); - - /* copy it properly if its a packet */ - if (s->first->t == a_packet){ - s->first->w.w_packet = pdp_packet_copy_ro(s->first->w.w_packet); - } - - return e_ok; -} - -t_pdp_word_error pdp_stack_swap(t_pdp_stack *s) -{ - t_pdp_word w; - t_pdp_word_type t; - if (s->elements < 2) return e_underflow; - w = s->first->w; - t = s->first->t; - s->first->w = s->first->next->w; - s->first->t = s->first->next->t; - s->first->next->w = w; - s->first->next->t = t; - return e_ok; - -} - -/* pushing and popping the stack */ - -t_pdp_word_error pdp_stack_push_float(t_pdp_stack *s, float f) {pdp_list_add(s, a_float, (t_pdp_word)f); return e_ok;} -t_pdp_word_error pdp_stack_push_int(t_pdp_stack *s, int i) {pdp_list_add(s, a_int, (t_pdp_word)i); return e_ok;} -t_pdp_word_error pdp_stack_push_pointer(t_pdp_stack *s, void *x) {pdp_list_add(s, a_pointer, (t_pdp_word)x); return e_ok;} -t_pdp_word_error pdp_stack_push_symbol(t_pdp_stack *s, t_pdp_symbol *x) {pdp_list_add(s, a_symbol, (t_pdp_word)x); return e_ok;} - -/* note: packets pushed stack are owned by the stack. if a caller wants to keep a packet that - will be deleted by the word, it should make a copy before transferring it to the stack. - if a stack processor wants to write to a packet, it should replace it with a writable copy first */ - -t_pdp_word_error pdp_stack_push_packet(t_pdp_stack *s, int p) {pdp_list_add(s, a_packet, (t_pdp_word)p); return e_ok;} - - - - - -t_pdp_word_error pdp_stack_pop_float(t_pdp_stack *s, float *f) -{ - if (!s->first) return e_underflow; - - if (s->first->t == a_float) *f = s->first->w.w_float; - else if (s->first->t == a_int) *f = (float)s->first->w.w_int; - else *f = 0.0f; - pdp_stack_drop(s); - return e_ok; -} - -t_pdp_word_error pdp_stack_pop_int(t_pdp_stack *s, int *i) -{ - if (!s->first) return e_underflow; - if (s->first->t == a_int) *i = s->first->w.w_int; - else if (s->first->t == a_float) *i = (int)s->first->w.w_float; - else *i = 0; - pdp_stack_drop(s); - return e_ok; -} - -t_pdp_word_error pdp_stack_pop_pointer(t_pdp_stack *s, void **x) -{ - if (!s->first) return e_underflow; - *x = (s->first->t == a_pointer) ? s->first->w.w_pointer : 0; - pdp_stack_drop(s); - return e_ok; -} - -t_pdp_word_error pdp_stack_pop_symbol(t_pdp_stack *s, t_pdp_symbol **x) -{ - if (!s->first) return e_underflow; - *x = (s->first->t == a_symbol) ? s->first->w.w_symbol : pdp_gensym("invalid"); - pdp_stack_drop(s); - return e_ok; -} - -/* packets popped from the stack are owned by the caller */ - -t_pdp_word_error pdp_stack_pop_packet(t_pdp_stack *s, int *p) -{ - if (!s->first) return e_underflow; - *p = (s->first->t == a_packet) ? s->first->w.w_packet : -1; - pdp_list_pop(s); //ownership is transferred to receiver, drop kills the packet - return e_ok; -} - - -t_pdp_word_error pdp_stack_mov(t_pdp_stack *s) -{ - int position; - t_pdp_atom *a, *a_before; - if (s->elements < 2) return e_underflow; - if (s->first->t != a_int) return e_type; - - pdp_stack_pop_int(s, &position); // get insert point - if (position < 1) return e_ok; // < 0 : invalid; do nothing, 0 : nop (= insert at start, but already at start) - if ((s->elements-1) < position) return e_underflow; - - a = s->first; // get first atom - s->first = a->next; - - if (s->elements-1 == position){ //insert at end - s->last->next = a; - a->next = 0; - s->last = a; - } - else { //insert somewhere in the middle - a_before = s->first; - while (--position) a_before = a_before->next; - a->next = a_before->next; - a_before->next = a; - } - return e_ok; -} - -/* rotate stack down (tos -> bottom) */ -t_pdp_word_error pdp_stack_rdown(t_pdp_stack *s) -{ - t_pdp_word_type t = s->first->t; - t_pdp_word w = s->first->w; - pdp_list_pop(s); - pdp_list_add_back(s, t, w); - return e_ok; -} - - -/* convert to int */ -t_pdp_word_error pdp_stack_int(t_pdp_stack *s) -{ - int i; - pdp_stack_pop_int(s, &i); - pdp_stack_push_int(s, i); - return e_ok; -} - -/* convert to float */ -t_pdp_word_error pdp_stack_float(t_pdp_stack *s) -{ - float f; - pdp_stack_pop_float(s, &f); - pdp_stack_push_float(s, f); - return e_ok; -} - - -#define OP1(name, type, op) \ -t_pdp_word_error pdp_stack_##name##_##type (t_pdp_stack *s) \ -{ \ - type x0; \ - pdp_stack_pop_##type (s, &(x0)); \ - pdp_stack_push_##type (s, op (x0)); \ - return e_ok; \ -} - -#define OP2(name, type, op) \ -t_pdp_word_error pdp_stack_##name##_##type (t_pdp_stack *s) \ -{ \ - type x0, x1; \ - pdp_stack_pop_##type (s, &(x0)); \ - pdp_stack_pop_##type (s, &(x1)); \ - pdp_stack_push_##type (s, x1 op x0); \ - return e_ok; \ -} - -/* some floating point and integer stuff */ - -OP2(add, float, +); -OP2(sub, float, -); -OP2(mul, float, *); -OP2(div, float, /); - -OP1(sin, float, sin); -OP1(cos, float, cos); - -OP2(add, int, +); -OP2(sub, int, -); -OP2(mul, int, *); -OP2(div, int, /); -OP2(mod, int, %); - -OP2(and, int, &); -OP2(or, int, |); -OP2(xor, int, ^); - - -/* some integer stuff */ - -t_pdp_word_error pdp_stack_push_invalid_packet(t_pdp_stack *s) -{ - pdp_stack_push_packet(s, -1); - return e_ok; -} - -/* dictionary manipulation */ - -void pdp_forth_word_print_debug(t_pdp_symbol *s) -{ - t_pdp_atom *a; - if (!s->s_word_spec){ - post("%s is not a forth word", s->s_name); - } - else{ - post(""); - post("forth word %s", s->s_name); - post("\tinput: %d", s->s_word_spec->input_size); - post("\toutput: %d", s->s_word_spec->output_size); - post("\ttype index: %d", s->s_word_spec->type_index); - - post("\nimplementations:"); - for(a=s->s_word_spec->implementations->first; a; a=a->next){ - t_pdp_forthword_imp *i = a->w.w_pointer; - startpost("\t%s\t", i->type ? i->type->s_name : "anything"); - pdp_list_print(i->def); - - } - post(""); - } -} - -/* add a definition (list of high level words (symbols) or primitive routines) */ -void pdp_forthdict_add_word(t_pdp_symbol *name, t_pdp_list *def, int input_size, int output_size, - int type_index, t_pdp_symbol *type) -{ - t_pdp_forthword_spec *spec = 0; - t_pdp_forthword_imp *imp = 0; - t_pdp_forthword_imp *old_imp = 0; - t_pdp_atom *a; - /* check if the word complies to a previously defined word spec with the same name */ - if (spec = name->s_word_spec){ - if ((spec->input_size != input_size) - ||(spec->output_size != output_size) - ||(spec->type_index != type_index)){ - post("ERROR: pdp_forthdict_add_word: new implementation of [%s] does not comply to old spec", - name->s_name); - return; - } - - } - /* no previous word spec with this name, so create a new spec */ - else{ - spec = name->s_word_spec = (t_pdp_forthword_spec *)pdp_alloc(sizeof(t_pdp_forthword_spec)); - spec->name = name; - spec->input_size = input_size; - spec->output_size = output_size; - spec->type_index = type_index; - spec->implementations = pdp_list_new(0); - } - - /* create the new implementation and add it */ - imp = (t_pdp_forthword_imp *)pdp_alloc(sizeof(t_pdp_forthword_imp)); - imp->name = name; - imp->def = def; - imp->type = type; - - /* can't delete old implemetations because of thread safety */ - pdp_list_add_pointer(spec->implementations, imp); - -} - -/* add a primitive */ -void pdp_forthdict_add_primitive(t_pdp_symbol *name, t_pdp_forthword w, int input_size, int output_size, - int type_index, t_pdp_symbol *type) -{ - t_pdp_list *def = pdp_list_new(1); - def->first->t = a_pointer; - def->first->w.w_pointer = w; - pdp_forthdict_add_word(name, def, input_size, output_size, type_index, type); -} - -/* parse a new definition from a null terminated string */ -t_pdp_list *pdp_forth_compile_def(char *chardef) -{ - t_pdp_list *l; - char *c; - - if (!(l = pdp_list_from_cstring(chardef, &c))){ - post ("ERROR: pdp_forth_compile_def: parse error parsing: %s", chardef); - if (*c) post ("ERROR: remaining input: %s", c); - } - if (*c){ - post ("WARNING: pdp_forth_compile_def: parsing: %s", chardef); - if (*c) post ("garbage at end of string: %s", c); - } - - return l; - -} - -void pdp_forthdict_compile_word(t_pdp_symbol *name, char *chardef, int input_size, int output_size, - int type_index, t_pdp_symbol *type) -{ - /* add the definition list to the dictionary */ - t_pdp_list *def; - - if (def = pdp_forth_compile_def (chardef)) - pdp_forthdict_add_word(name, def, input_size, output_size, type_index, type); - - -} - - - -/* execute a definition list - a def list is a list of primitives, immediates or symbolic words */ -t_pdp_word_error pdp_forth_execute_def(t_pdp_stack *stack, t_pdp_list *def) -{ - t_pdp_atom *a; - t_pdp_word_error e; - t_pdp_forthword w; - float f; - int i,p; - - D post("pdp_forth_execute_def %x %x", stack, def); - D pdp_list_print(def); - - for (a = def->first; a; a=a->next){ - switch(a->t){ - case a_float: // an immidiate float - f = a->w.w_float; - D post("pushing %f onto the stack", f); - pdp_stack_push_float(stack, f); - break; - case a_int: // an immidiate int - i = a->w.w_int; - D post("pushing %d onto the stack", i); - pdp_stack_push_int(stack, i); - break; - case a_packet: // an immidiate int - p = a->w.w_packet; - D post("pushing packet %d onto the stack", p); - pdp_stack_push_packet(stack, pdp_packet_copy_ro(p)); - break; - case a_symbol: // a high level word or an immediate symbol - D post("interpeting symbol %s", a->w.w_symbol->s_name); - if (e = pdp_forth_execute_word(stack, a->w.w_symbol)) return e; - break; - case a_pointer: // a primitive - w = a->w.w_pointer; - D post("exec primitive %x", w); - if (e = (w(stack))) return e; - break; - default: - return e_internal; - - } - } - return e_ok; -} - -/* execute a symbol (a high level word or an immediate) - this routine does the type based word multiplexing and stack checking */ -t_pdp_word_error pdp_forth_execute_word(t_pdp_stack *stack, t_pdp_symbol *word) -{ - t_pdp_symbol *type = 0; - t_pdp_atom *a; - t_pdp_forthword_spec *spec; - t_pdp_forthword_imp *imp = 0; - int i; - - D post("pdp_forth_execute_word %x %x", stack, word); - - /* first check if the word is defined. if not, the symbol will be loaded - onto the stack as an immidiate symbol */ - - if (!(spec = word->s_word_spec)){ - D post ("pushing symbol %s on the stack", word->s_name); - pdp_stack_push_symbol(stack, word); - return e_ok; - } - - D post("exec high level word [%s]", word->s_name); - - /* it is a word. check the stack size */ - if (stack->elements < spec->input_size){ - D post ("error executing [%s]: stack underflow", word->s_name); - return e_underflow; - } - - /* if the word is type oblivious, symply execute the first (only) - implementation in the list */ - if (spec->type_index < 0){ - D post("exec type oblivious word [%s]", word->s_name); - imp = spec->implementations->first->w.w_pointer; - return pdp_forth_execute_def(stack , imp->def); - } - - /* if it is not type oblivious, find the type template - to determine the correct implementation */ - - for(i=spec->type_index,a=stack->first; i--; a=a->next); - switch (a->t){ - /* get type description from first item on*/ - case a_packet: - type = pdp_packet_get_description(a->w.w_packet); break; - case a_symbol: - type = a->w.w_symbol; break; - case a_float: - type = pdp_gensym("float"); break; - case a_int: - type = pdp_gensym("int"); break; - case a_pointer: - type = pdp_gensym("pointer"); break; - default: - /* no type description found on top of stack. */ - type = pdp_gensym("unknown"); - break; - } - - /* scan the implementation list until a definition with matching type is found - if the type spec for a word is NULL, it counts as a match (for generic words) */ - for (a = spec->implementations->first; a; a = a->next){ - imp = a->w.w_pointer; - if ((!imp->type) || pdp_type_description_match(type, imp->type)){ - return pdp_forth_execute_def(stack , imp->def); - } - } - D post("ERROR: pdp_forth_execute_word: type error executing [%s] (2). stack:",word->s_name); - D pdp_list_print(stack); - - return e_type; // type error - -} - - -static void _add_2op(char *name, t_pdp_forthword w, char *type){ - pdp_forthdict_add_primitive(pdp_gensym(name), w, 2, 1, 0, pdp_gensym(type)); -} - -static void _add_1op(char *name, t_pdp_forthword w, char *type){ - pdp_forthdict_add_primitive(pdp_gensym(name), w, 1, 1, 0, pdp_gensym(type)); -} - - -void pdp_forth_setup(void) -{ - - /* add type oblivious (type_index = -1, type = NULL) stack manip primitives */ - pdp_forthdict_add_primitive(pdp_gensym("dup"), (t_pdp_forthword)pdp_stack_dup, 1, 2, -1, 0); - pdp_forthdict_add_primitive(pdp_gensym("swap"), (t_pdp_forthword)pdp_stack_swap, 2, 2, -1, 0); - pdp_forthdict_add_primitive(pdp_gensym("drop"), (t_pdp_forthword)pdp_stack_drop, 1, 0, -1, 0); - pdp_forthdict_add_primitive(pdp_gensym("over"), (t_pdp_forthword)pdp_stack_over, 2, 3, -1, 0); - pdp_forthdict_add_primitive(pdp_gensym("mov"), (t_pdp_forthword)pdp_stack_mov, 2, 1, -1, 0); - pdp_forthdict_add_primitive(pdp_gensym("down"), (t_pdp_forthword)pdp_stack_rdown, 1, 1, -1, 0); - - /* type converters (casts) */ - pdp_forthdict_add_primitive(pdp_gensym("int"), (t_pdp_forthword)pdp_stack_int, 1, 1, -1, 0); - pdp_forthdict_add_primitive(pdp_gensym("float"), (t_pdp_forthword)pdp_stack_float, 1, 1, -1, 0); - - /* add floating point ops */ - _add_2op("add", (t_pdp_forthword)pdp_stack_add_float, "float"); - _add_2op("sub", (t_pdp_forthword)pdp_stack_sub_float, "float"); - _add_2op("mul", (t_pdp_forthword)pdp_stack_mul_float, "float"); - _add_2op("div", (t_pdp_forthword)pdp_stack_div_float, "float"); - - _add_1op("sin", (t_pdp_forthword)pdp_stack_sin_float, "float"); - _add_1op("cos", (t_pdp_forthword)pdp_stack_cos_float, "float"); - - /* add integer ops */ - _add_2op("add", (t_pdp_forthword)pdp_stack_add_int, "int"); - _add_2op("sub", (t_pdp_forthword)pdp_stack_sub_int, "int"); - _add_2op("mul", (t_pdp_forthword)pdp_stack_mul_int, "int"); - _add_2op("div", (t_pdp_forthword)pdp_stack_div_int, "int"); - _add_2op("mod", (t_pdp_forthword)pdp_stack_mod_int, "int"); - - _add_2op("and", (t_pdp_forthword)pdp_stack_and_int, "int"); - _add_2op("or", (t_pdp_forthword)pdp_stack_or_int, "int"); - _add_2op("xor", (t_pdp_forthword)pdp_stack_xor_int, "int"); - - /* some immidiates */ - pdp_forthdict_add_primitive(pdp_gensym("ip"), (t_pdp_forthword)pdp_stack_push_invalid_packet, 0, 1, -1, 0); - -} -- cgit v1.2.1