aboutsummaryrefslogtreecommitdiff
path: root/guile/pdp_guile.c
diff options
context:
space:
mode:
Diffstat (limited to 'guile/pdp_guile.c')
-rw-r--r--guile/pdp_guile.c705
1 files changed, 0 insertions, 705 deletions
diff --git a/guile/pdp_guile.c b/guile/pdp_guile.c
deleted file mode 100644
index 34ca8da..0000000
--- a/guile/pdp_guile.c
+++ /dev/null
@@ -1,705 +0,0 @@
-/*
- * Pure Data Packet module: Guile Interpreter for pd/pdp
- * Copyright (c) by Tom Schouten <pdp@zzz.kotnet.org>
- *
- * 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 <pthread.h>
-#include <libguile.h>
-#include <stdio.h>
-#include "pdp.h"
-#include "pdp_forth.h"
-
-#define D if(0)
-
-
-
-/* communication stuff */
-
-static t_class *guile_class;
-
-pthread_mutex_t guile_mux;
-
-t_pdp_list *guile_inlist;
-t_pdp_list *guile_outlist;
-t_clock *guile_clock;
-t_float guile_clock_deltime;
-
-
-/* GUILE GLUE CODE */
-
-static scm_t_bits pdp_tag;
-
-typedef struct _pdp_scm_wrapper
-{
- int packet;
- SCM update_func;
- //char dummy[1000000];
-} t_pdp_scm_wrapper;
-
-
-/* list (comm queue) utility stuff */
-
-static void guile_list_send(t_pdp_list *list, t_pdp_symbol *tag, t_pdp_word_type type, t_pdp_word word)
-{
- pthread_mutex_lock(&guile_mux);
- pdp_list_add_back(list, a_symbol, (t_pdp_word)tag);
- pdp_list_add_back(list, type, word);
- pthread_mutex_unlock(&guile_mux);
-}
-
-static int guile_list_receive(t_pdp_list *list, t_pdp_symbol **tag, t_pdp_word_type *type, t_pdp_word *word)
-{
- int success = 0;
- if (pdp_list_size(list)){
- pthread_mutex_lock(&guile_mux);
- *tag = pdp_list_pop(list).w_symbol;
- *type = list->first->t;
- *word = pdp_list_pop(list);
- pthread_mutex_unlock(&guile_mux);
- success = 1;
- }
- return success;
-
-}
-
-/* pdp list <-> scm list conversion */
-
-/* any packets contained in the pdp list are copied ro */
-
-static SCM pdp_to_scm (t_pdp_list *l)
-{
- SCM pair = SCM_EOL; //temporary pair
- SCM thing; //thing to add to the list
- t_pdp_list *cl = pdp_list_copy_reverse(l); //make a reverse copy of the list
- t_pdp_atom *a;
- t_pdp_scm_wrapper *pg;
-
- for(a=cl->first;a;a=a->next){
-
- // convert the atom to a lisp scalar
- switch (a->t){
- case a_list:
- thing = pdp_to_scm(a->w.w_list); break;
- case a_int:
- thing = SCM_MAKINUM(a->w.w_int); break;
- case a_symbol:
- thing = scm_str2symbol(a->w.w_symbol->s_name); break;
- case a_float:
- thing = scm_make_real (a->w.w_float); break;
- case a_packet:
- //post("ATTENTION: pdp_to_scm copies packets");
- pg = (t_pdp_scm_wrapper *) scm_must_malloc (sizeof (t_pdp_scm_wrapper), "pdp");
- pg->packet = pdp_packet_copy_ro(a->w.w_packet);
- pg->update_func = SCM_BOOL_F;
- SCM_NEWSMOB (thing, pdp_tag, pg);
- break;
- default:
- thing = scm_str2symbol("undef"); break;
- }
-
- // add the atom to the list
- pair = scm_cons(thing, pair); // add thing
-
- }
-
- //
-
- // return the list
- return pair;
-}
-
-/* any packets contained in the list are copied ro */
-static t_pdp_list *scm_to_pdp (SCM pair)
-{
- t_pdp_list *l = pdp_list_new(0);
- SCM rest = pair;
- SCM head;
- while (1){
- if (!SCM_CONSP(rest)){
- head = rest;
- rest = SCM_EOL;
- }
- else {
- head = SCM_CAR(rest);
- rest = SCM_CDR(rest);
- }
- if (SCM_NULLP(head)) break;
-
- else if (SCM_CONSP(head)){
- pdp_list_add_back(l, a_list, (t_pdp_word)scm_to_pdp(head));
- }
- else if (SCM_SMOB_PREDICATE(pdp_tag, head)){
- t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (head);
- //post("ATTENTION: scm_to_pdp copies packets");
- pdp_list_add_back(l, a_packet,
- (t_pdp_word)(pdp_packet_copy_ro(pg->packet)));
- }
- else if (SCM_INUMP(head)){
- int i = SCM_INUM(head);
- pdp_list_add_back(l, a_int, (t_pdp_word)i);
- }
- else if (SCM_REALP(head)){
- float f = (float)SCM_REAL_VALUE(head);
- pdp_list_add_back(l, a_float, (t_pdp_word)f);
- }
- else if (SCM_SYMBOLP(head)){
- pdp_list_add_back(l, a_symbol,
- (t_pdp_word)pdp_gensym(SCM_SYMBOL_CHARS(head)));
- }
- else {
- pdp_list_add_back(l, a_undef, (t_pdp_word)0);
- }
- }
- return l;
-}
-
-
-
-
-/* smob callbacks */
-
-static SCM mark_pdp (SCM pdp_smob)
-{
- /* Mark the image's name and update function. */
- t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob);
- scm_gc_mark (pg->update_func);
- D post("mark_pdp called");
- return SCM_BOOL_F;
-}
-
-static size_t free_pdp (SCM pdp_smob)
-{
- t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob);
- pdp_packet_mark_unused(pg->packet);
- scm_must_free(pg);
- D post("free_pdp called");
- return sizeof(t_pdp_scm_wrapper);
-}
-
-
-static int
-print_pdp (SCM pdp_smob, SCM port, scm_print_state *pstate)
-{
- t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob);
- char tmp[1000];
- t_pdp *h = pdp_packet_header(pg->packet);
- tmp[999] = 0;
- snprintf(tmp, 999, "#<pdp %d %s>", pg->packet,
- h && h->desc ? h->desc->s_name : "unknown");
- scm_puts(tmp, port);
- D post ("print_pdp called");
- return 1;
-}
-
-
-/* extension functions */
-
-
-static SCM
-forth_pdp (SCM stack, SCM program)
-{
- t_pdp_word_error e;
- t_pdp_list *s = scm_to_pdp (stack);
- t_pdp_list *p = scm_to_pdp (program);
- e = pdp_forth_execute_def(s, p);
- stack = pdp_to_scm(s);
-
- if (e){
- post("ERROR: program evaluation aborted with error %d.", e);
- }
- pdp_tree_strip_packets(s);
- pdp_tree_strip_packets(p);
-
- return stack;
-
-}
-
-static SCM
-define_forth_word_pdp (SCM word, SCM in, SCM out, SCM program)
-{
- t_pdp_word_error e;
- t_pdp_list *p;
- t_pdp_symbol *s;
- SCM_ASSERT (SCM_SYMBOLP(word), word, SCM_ARG1, "define-forth-word");
- SCM_ASSERT (SCM_INUMP(in), word, SCM_ARG2, "define-forth-word");
- SCM_ASSERT (SCM_INUMP(out), word, SCM_ARG3, "define-forth-word");
- p = scm_to_pdp (program);
- s = pdp_gensym(SCM_SYMBOL_CHARS(word));
- pdp_forthdict_add_word(s, p, SCM_INUM(in), SCM_INUM(out), -1, 0);
-
- return SCM_UNSPECIFIED;
-
-}
-
-
-static SCM
-unmark_pdp (SCM pdp_smob)
-{
- t_pdp_scm_wrapper *pg;
- SCM_ASSERT (SCM_SMOB_PREDICATE (pdp_tag, pdp_smob),
- pdp_smob, SCM_ARG1, "mark-unused");
- pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob);
- pdp_packet_mark_unused(pg->packet);
- pg->packet = -1;
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-static SCM
-is_writable_pdp (SCM pdp_smob)
-{
- t_pdp_scm_wrapper *pg;
- SCM_ASSERT (SCM_SMOB_PREDICATE (pdp_tag, pdp_smob),
- pdp_smob, SCM_ARG1, "writable?");
- pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob);
- if (pdp_packet_writable(pg->packet)) return SCM_BOOL_T;
- else return SCM_BOOL_F;
- return SCM_UNSPECIFIED;
-}
-
-static SCM
-make_pdp (SCM type)
-{
- int p;
- t_pdp_scm_wrapper *pg;
- char *t;
-
- /* construct with type */
- if (SCM_SYMBOLP(type)){
- t = SCM_SYMBOL_CHARS(type);
- p = pdp_factory_newpacket(pdp_gensym(t));
- }
- /* copy construct from packet id */
- else if (SCM_INUMP(type)){
- int i = SCM_INUM(type);
- p = pdp_packet_copy_ro(i);
- }
- else {
- SCM_ASSERT (0, type, SCM_ARG1, "make-pdp");
- }
-
- /* check if valid packet */
- SCM_ASSERT (p != -1, type, SCM_ARG1, "make-pdp");
-
- /* build smob */
- pg = (t_pdp_scm_wrapper *) scm_must_malloc (sizeof (t_pdp_scm_wrapper), "pdp");
- pg->packet = p;
- pg->update_func = SCM_BOOL_F;
- SCM_RETURN_NEWSMOB (pdp_tag, pg);
-}
-
-static SCM
-_in (void)
-{
-
- t_pdp_scm_wrapper *pg;
- t_pdp_word w;
- t_pdp_symbol *stag;
- t_pdp_word_type type = a_undef;
- int skip = 1;
-
- SCM tag;
- SCM thing;
- SCM pair;
-
- D post("receiving pdp packet");
-
- if (!guile_list_receive(guile_inlist, &stag, &type, &w)) goto exit;
- tag = scm_str2symbol(stag->s_name);
-
- switch(type){
- case a_packet:
- pg = (t_pdp_scm_wrapper *) scm_must_malloc (sizeof (t_pdp_scm_wrapper), "pdp");
- pg->packet = w.w_packet;
- pg->update_func = SCM_BOOL_F;
- SCM_NEWSMOB (thing, pdp_tag, pg);
- break;
- case a_symbol:
- thing = scm_str2symbol(w.w_symbol->s_name);
- break;
- case a_float:
- thing = scm_make_real (w.w_float);
- break;
-
- default:
- goto exit;
-
- }
- pair = scm_cons2(tag, thing, SCM_EOL);
- return pair;
-
-
- exit:
- return SCM_BOOL_F;
-}
-
-static SCM
-_out (SCM tag, SCM thing)
-{
- t_pdp_symbol *stag;
- SCM_ASSERT (SCM_SYMBOLP (tag), tag, SCM_ARG1, "out");
- stag = pdp_gensym(SCM_SYMBOL_CHARS(tag));
-
- if (SCM_SMOB_PREDICATE(pdp_tag, thing)){
- t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (thing);
- guile_list_send(guile_outlist, stag, a_packet,
- (t_pdp_word)(pdp_packet_copy_ro(pg->packet)));
- }
- else if (SCM_INUMP(thing)){
- int i = SCM_INUM(thing);
- guile_list_send(guile_outlist, stag, a_int, (t_pdp_word)i);
- }
- else if (SCM_REALP(thing)){
- float f = (float)SCM_REAL_VALUE(thing);
- guile_list_send(guile_outlist, stag, a_float, (t_pdp_word)f);
- }
- else if (SCM_SYMBOLP(thing)){
- char *s = SCM_SYMBOL_CHARS(thing);
- guile_list_send(guile_outlist, stag, a_symbol, (t_pdp_word)(pdp_gensym(s)));
- }
- else if (SCM_CONSP(thing)){
- t_pdp_list *l = scm_to_pdp(thing);
- guile_list_send(guile_outlist, stag, a_list, (t_pdp_word)l);
- }
- else{
- SCM_ASSERT (0, thing, SCM_ARG2, "out");
- }
-
- return SCM_BOOL_T;
-
-}
-
-
-static SCM
-test_pdp (SCM thing)
-{
- if (SCM_SMOB_PREDICATE(pdp_tag, thing)) return SCM_BOOL_T;
- else return SCM_BOOL_F;
-}
-static SCM
-printdebugforthword_pdp (SCM thing)
-{
- t_pdp_symbol *s;
- t_pdp_atom *a;
- SCM_ASSERT (SCM_SYMBOLP(thing), thing, SCM_ARG1, "pdp-debug-forth-word");
- s = pdp_gensym(SCM_SYMBOL_CHARS(thing));
-
- pdp_forth_word_print_debug(s);
-
- return SCM_UNSPECIFIED;
-
-}
-
-static SCM
-printdebug_pdp (SCM thing)
-{
- if (SCM_INUMP(thing)){
- int p = SCM_INUM(thing);
- pdp_packet_print_debug(p);
- return SCM_UNSPECIFIED;
- }
-
- SCM_ASSERT (SCM_SMOB_PREDICATE(pdp_tag, thing), thing, SCM_ARG1, "pdp-debug-packet");
- pdp_packet_print_debug(((t_pdp_scm_wrapper *) SCM_SMOB_DATA (thing))->packet);
- return SCM_UNSPECIFIED;
-
-}
-/* the inner main function. when this is called, guile
- is initialized. when this function returns, exit(0)
- is called. */
-static void guile_inner_main(void *closure, int argv, char **argc)
-{
- /* initialize data types and functions */
- pdp_tag = scm_make_smob_type ("pdp", sizeof(t_pdp_scm_wrapper));
- scm_set_smob_free (pdp_tag, free_pdp);
- scm_set_smob_print (pdp_tag, print_pdp);
- scm_set_smob_mark (pdp_tag, mark_pdp);
-
- /* pdp stuff */
- scm_c_define_gsubr ("make-pdp", 1, 0, 0, make_pdp);
- scm_c_define_gsubr ("writable?", 1, 0, 0, is_writable_pdp);
- scm_c_define_gsubr ("pdp?", 1, 0, 0, test_pdp);
-
- /* communication */
- scm_c_define_gsubr ("in", 0, 0, 0, _in);
- scm_c_define_gsubr ("out", 2, 0, 0, _out);
-
- /* pdp forth link */
- scm_c_define_gsubr ("forth", 2, 0, 0, forth_pdp);
- scm_c_define_gsubr ("define-forth-word", 4, 0, 0, define_forth_word_pdp);
-
- /* debug methods */
- scm_c_define_gsubr ("mark-unused", 1, 0, 0, unmark_pdp);
- scm_c_define_gsubr ("pdp-debug-packet", 1, 0, 0, printdebug_pdp);
- scm_c_define_gsubr ("pdp-debug-forth-word", 1, 0, 0, printdebugforthword_pdp);
-
- /* start the shell */
- scm_c_eval_string("(set! scm-repl-prompt \"pdp> \")");
-
- //scm_c_eval_string("(load \"/home/tom/.guile\")");
- //while(1) {
- //post("read evaluate print loop");
- //scm_c_eval_string("(display scm-repl-prompt)(display (eval (read) (current-module)))(newline)");
- //}
-
- scm_shell(0,0);
-}
-
-
-/* the outer main function for booting the guile system
- this is a separate thread */
-static void *guile_main(void *x)
-{
- scm_boot_guile(0,0,guile_inner_main,0);
- return 0;
-}
-
-
-/* start the thread that boots the guile system */
-static void guile_boot_in_thread(void)
-{
- pthread_t thread;
- pthread_attr_t attr;
-
- pthread_attr_init(&attr);
- pthread_attr_setschedpolicy(&attr, SCHED_OTHER);
- pthread_create(&thread, &attr, guile_main, 0);
-
-}
-
-
-/* some restrictions on the pdp -> pd list conversion:
-
- - due to the nature of the pdp protocol in pd (3 phase)
- a packet can not appear in a pd list. it will be sent out
- as a pdp packet to the receiver corresponding to the tag.
- the legal way to send a packet from guile is (out 'tag packet)
-
- - pd lists cannot be recursive, so pdp trees will need to be
- flattened first.
-*/
-
-/* this sends a (flat pdp list) to a pd receiver
- the list cannot contain pdp packets */
-static void pd_pdplist(void *thing, t_symbol *tag, t_pdp_list *l, int elements){
- t_atom pd_atom[elements];
- int i;
- t_pdp_atom *a = l->first;
- for (i=0; i<elements; i++,a=a->next){
- switch(a->t){
- case a_float:
- SETFLOAT(pd_atom+i, a->w.w_float); break;
- case a_int:
- SETFLOAT(pd_atom+i, (float)a->w.w_int); break;
- case a_pointer:
- SETPOINTER(pd_atom+i, a->w.w_pointer); break;
- case a_symbol:
- SETSYMBOL(pd_atom+i, gensym(a->w.w_symbol->s_name)); break;
- case a_packet:
- post("ERROR: can't put packet %d inside a pd list (not a pd atom)",
- a->w.w_packet);
- SETSYMBOL(pd_atom+i, gensym("deadpacket")); break;
- case a_list:
- post("ERROR: can't put a list inside a pd list (not a pd atom):");
- pdp_list_print(a->w.w_list);
- SETSYMBOL(pd_atom+i, gensym("deadlist")); break;
- default:
- SETSYMBOL(pd_atom+i, gensym("undef")); break;
-
- }
- }
- typedmess(thing, tag, elements, pd_atom);
-
-
- pdp_tree_strip_packets(l);
- pdp_tree_free(l);
-}
-
-
-
-static void guile_callback(void *dummy)
-{
- int skip = 1;
- t_pdp_symbol *s = 0;
- t_pdp_word_type type = a_undef;
- t_pdp_word w;
- t_atom atom[3];
- void *thing;
-
- t_symbol *tag_sym;
-
- if (!guile_list_receive(guile_outlist, &s, &type, &w)) goto exit;
-
- tag_sym = gensym(s->s_name);
- thing = tag_sym->s_thing;
-
- //post("got something from guile");
-
- if (!thing) goto exit;
-
-
-
- /* send to outlet */
- switch(type){
- case a_packet:
- SETFLOAT(atom+1, (float)w.w_packet);
- SETSYMBOL(atom+0, pdp_sym_rro());
- typedmess(thing, pdp_sym_pdp(), 2, atom);
- SETSYMBOL(atom+0, pdp_sym_rrw());
- typedmess(thing, pdp_sym_pdp(), 2, atom);
- SETSYMBOL(atom+0, pdp_sym_prc());
- typedmess(thing, pdp_sym_pdp(), 2, atom);
- pdp_packet_mark_unused(w.w_packet);
- break;
-
- case a_float:
- pd_float(thing, w.w_float);
- break;
-
- case a_int:
- pd_float(thing, (float)w.w_int);
- break;
-
- case a_symbol:
- pd_symbol(thing, gensym(w.w_symbol->s_name));
- break;
-
- case a_list:{
- int elements = w.w_list->elements;
- t_symbol *tag;
-
- if (elements){
- /* if first element is a symbol, we use it to tag the list */
- if (w.w_list->first->t == a_symbol){
- tag = gensym(w.w_list->first->w.w_symbol->s_name);
- elements--;
- pdp_list_pop(w.w_list);
- pd_pdplist(thing, tag, w.w_list, elements);
- }
- /* else tag it as "list" */
- else {
- pd_pdplist(thing, gensym("list"), w.w_list, elements);
-
- }
- }
- else{ //an empty list is a bang
- pd_bang(thing);
- }
- break;
- }
-
- default:
- break;
- }
-
- exit:
- clock_delay(guile_clock, guile_clock_deltime);
-}
-
-
-
-/* PD INTERFACE OBJECT */
-
-t_class *scheme_send_class;
-
-typedef struct _scheme_send
-{
- t_object x_obj;
- t_outlet *x_outlet;
- t_pdp_symbol *x_tag;
-} t_scheme_send;
-
-
-static void *scheme_send_new(t_symbol *s)
-{
- t_scheme_send *x = 0;
- x = (t_scheme_send *)pd_new(scheme_send_class);
-
- x->x_tag = (s == gensym("")) ?
- x->x_tag = pdp_gensym("dummy") : pdp_gensym(s->s_name);
-
- return (void*)x;
-}
-
-static void scheme_send_anything(t_scheme_send *x, t_symbol *s, int argc, t_atom *argv)
-{
- void *thing = 0;
-
- if (s == &s_float && argc == 1 && argv[0].a_type == A_FLOAT){
- guile_list_send(guile_inlist, x->x_tag, a_float,
- (t_pdp_word)argv[1].a_w.w_float);
- }
-
- else if (s == &s_symbol && argc == 1 && argv[0].a_type == A_SYMBOL){
- guile_list_send(guile_inlist, x->x_tag, a_symbol,
- (t_pdp_word)pdp_gensym(argv[0].a_w.w_symbol->s_name));
- }
-
- else if (argc == 0){
- guile_list_send(guile_inlist, x->x_tag, a_symbol,
- (t_pdp_word)pdp_gensym(s->s_name));
- }
-
- else if (s == gensym("pdp")
- && argc == 2
- && argv[0].a_type == A_SYMBOL
- && argv[0].a_w.w_symbol == gensym("register_ro")
- && argv[1].a_type == A_FLOAT){
-
- guile_list_send(guile_inlist, x->x_tag, a_packet,
- (t_pdp_word)pdp_packet_copy_ro((int)argv[1].a_w.w_float));
- }
-
-}
-
-
-
-
-static void scheme_send_free(t_scheme_send *x)
-{
-}
-
-void pdp_guile_setup(void)
-{
-
- post("PDP: scheme extension");
-
- /* setup guile interpreter */
- guile_boot_in_thread();
-
- /* setup communication stuff */
- guile_inlist = pdp_list_new(0);
- guile_outlist = pdp_list_new(0);
-
- pthread_mutex_init(&guile_mux, NULL);
- guile_clock_deltime = 1.0f;
- guile_clock = clock_new(0, (t_method)guile_callback);
- clock_delay(guile_clock, guile_clock_deltime);
-
-
-
- /* create interface class */
- scheme_send_class = class_new(gensym("ss"), (t_newmethod)scheme_send_new,
- (t_method)scheme_send_free, sizeof(t_scheme_send), 0, A_DEFSYMBOL, A_NULL);
-
- class_addanything(scheme_send_class, scheme_send_anything);
-}
-
generated by cgit v1.2.1 (git 2.18.0) at 2024-11-09 04:09:48 +0000