From baecc2dc2449d04b44917a5114bf71262d65da30 Mon Sep 17 00:00:00 2001
From: "Kjetil S. Matheussen" <ksvalast@users.sourceforge.net>
Date: Thu, 8 Jan 2004 14:55:24 +0000
Subject: First commit of k_vst~, k_guile and k_cext

svn path=/trunk/externals/k_guile/; revision=1253
---
 global.scm | 173 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 173 insertions(+)
 create mode 100644 global.scm

(limited to 'global.scm')

diff --git a/global.scm b/global.scm
new file mode 100644
index 0000000..121852e
--- /dev/null
+++ b/global.scm
@@ -0,0 +1,173 @@
+
+
+;; These functions are global functions available for all guile scripts loaded into PD.
+;; Kjetil S. Matheussen, 2004.
+
+;;/* 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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.  */
+;;/*                                                                              */
+
+
+
+(debug-enable 'debug)
+(debug-enable 'trace)
+(debug-enable 'backtrace)
+
+(use-modules (ice-9 stack-catch))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Misc. functions
+;;
+;;
+(define (pd-display . args)
+  (if (not (null? args))
+      (begin
+	(display (car args))
+	(apply pd-display (cdr args)))
+      (newline)))
+
+(define (pd-filter proc list)
+  (if (null? list)
+      '()
+      (if (proc (car list))
+	  (cons (car list) (pd-filter proc (cdr list)))
+	  (pd-filter proc (cdr list)))))
+
+(define (pd-for init pred least add proc)
+  (if (pred init least)
+      (begin
+	(proc init)
+	(pd-for (+ add init) pred least add proc))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Argument checking
+;;
+;;
+(define (pd-check-number number message)
+  (if (number? number)
+      #t
+      (begin
+	(pd-display message ": " number " is not a number")
+	#f)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Bindings
+;;
+;;
+(define pd-global-bindings '())
+
+(define (pd-bind-do symbol func bindings)
+  (if (or (not (symbol? symbol))
+	  (not (procedure? func)))
+      (begin
+	(pd-display "Wrong arguments for pd-bind")
+	bindings)
+      (cons (list symbol 
+		  func
+		  (pd-c-bind symbol func))
+	    bindings)))
+
+(define (pd-unbind-do symbol bindings)
+  (if (not (symbol? symbol))
+      (begin
+	(pd-display "Wrong arguments for pd-unbind")
+	bindings)
+      (let ((binding (assq symbol bindings)))
+	(pd-c-unbind (caddr binding) symbol)
+	(pd-filter (lambda (x) (not (eq? symbol (car x))))
+		   bindings))))
+
+(define (pd-bind symbol func)
+  (set! pd-global-bindings (pd-bind-do symbol func pd-global-bindings)))
+
+(define (pd-unbind symbol)
+  (set! pd-global-bindings (pd-unbind-do symbol pd-global-bindings)))
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Sending
+;;
+;;
+(define (pd-send symbol firstarg . args)
+  (if (or (symbol? symbol)
+	  (number? symbol))
+      (cond ((> (length args) 0) (pd-c-send-list symbol (cons firstarg args)))
+	    ((list? firstarg) (pd-c-send-list symbol firstarg))
+	    ((number? firstarg) (pd-c-send-number symbol firstarg))
+	    ((string? firstarg) (pd-c-send-string symbol firstarg))
+	    ((eq? 'bang firstarg) (pd-c-send-bang symbol))
+	    ((symbol? firstarg) (pd-c-send-symbol symbol firstarg))
+	    (else
+	     (pd-display "Unknown argument to pd-outlet-or-send:" firstarg)))))
+
+(define (pd-get-symbol sym)
+  (if (not (symbol? sym))
+      (pd-display sym " is not a scheme symbol")
+      (pd-c-get-symbol sym)))
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Backtrace (does not work properly)
+;;
+;;
+(define (pd-display-errorfunc key . args)
+  (let ((dasstack (make-stack #t)))
+    (display-backtrace dasstack (current-output-port) #f #f)
+					;(display (stack-ref (make-stack #t) 1))
+					;(display (stack-length (make-stack #t)))
+    (display key)(newline)
+    (display args)
+    (newline))
+  0)
+
+(define (pd-backtrace-run thunk)
+  (stack-catch #t
+	       thunk
+	       pd-display-errorfunc))
+
+(define (pd-backtrace-run1 func arg1)
+  (stack-catch #t
+	       (lambda ()
+		 (func arg1))
+	       pd-display-errorfunc))
+
+(define (pd-backtrace-run2 func arg1 arg2)
+  (stack-catch #t
+	       (lambda ()
+		 (func arg1 arg2))
+	       pd-display-errorfunc))
+
+(define (pd-backtrace-run3 func arg1 arg2 arg3)
+  (stack-catch #t
+	       (lambda ()
+		 (func arg1 arg2 arg3))
+	       pd-display-errorfunc))
+
+(define (pd-backtrace-run4 func arg1 arg2 arg3 arg4)
+  (stack-catch #t
+	       (lambda ()
+		 (func arg1 arg2 arg3 arg4))
+	       pd-display-errorfunc))
+
+
-- 
cgit v1.2.1