foo-cvs — mailing list for CVS commit messages.

[foo-cvs] foo/elkfoo/examples/scripts Makefile.am,1.1,1.2

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples/scripts
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1576/examples/scripts

Modified Files:
	Makefile.am 
Log Message:
remove autotools from DIST_SUBDIRS in order to make 'make dist' shut up.  added example .foo files to dist files

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/examples/scripts/Makefile.am,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Makefile.am	12 Aug 2004 23:15:38 -0000	1.1
--- Makefile.am	12 Aug 2004 23:43:50 -0000	1.2
***************
*** 6,10 ****
  NULL = 
  
! noinst_DATA = \
  	sine.foo \
  	sndcat.foo \
--- 6,14 ----
  NULL = 
  
! EXTRA_DIST = $(EXAMPLE_SCRIPTS_FILES)
! 
! noinst_DATA = $(EXAMPLE_SCRIPTS_FILES)
! 
! EXAMPLE_SCRIPTS_FILES = \
  	sine.foo \
  	sndcat.foo \

[foo-cvs] foo/elkfoo/examples/kernel Makefile.am,1.1,1.2

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples/kernel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1576/examples/kernel

Modified Files:
	Makefile.am 
Log Message:
remove autotools from DIST_SUBDIRS in order to make 'make dist' shut up.  added example .foo files to dist files

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/examples/kernel/Makefile.am,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Makefile.am	12 Aug 2004 23:15:38 -0000	1.1
--- Makefile.am	12 Aug 2004 23:43:49 -0000	1.2
***************
*** 6,10 ****
  NULL = 
  
! noinst_DATA = \
  	biquad.foo \
  	fof.foo \
--- 6,14 ----
  NULL = 
  
! EXTRA_DIST = $(EXAMPLE_KERNEL_FILES)
! 
! noinst_DATA = $(EXAMPLE_KERNEL_FILES)
! 
! EXAMPLE_KERNEL_FILES = \
  	biquad.foo \
  	fof.foo \

[foo-cvs] foo/elkfoo Makefile.am,1.3,1.4

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1576

Modified Files:
	Makefile.am 
Log Message:
remove autotools from DIST_SUBDIRS in order to make 'make dist' shut up.  added example .foo files to dist files

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/Makefile.am,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Makefile.am	12 Aug 2004 23:15:37 -0000	1.3
--- Makefile.am	12 Aug 2004 23:43:49 -0000	1.4
***************
*** 7,11 ****
  
  SUBDIRS = include src scm examples
! DIST_SUBDIRS = $(SUBDIRS) autotools m4
  
  EXTRA_DIST = \
--- 7,11 ----
  
  SUBDIRS = include src scm examples
! DIST_SUBDIRS = $(SUBDIRS) m4
  
  EXTRA_DIST = \

[foo-cvs] foo/elkfoo/examples/kernel Makefile.am,NONE,1.1 biquad.foo,NONE,1.1 fof.foo,NONE,1.1 manual_mix.foo,NONE,1.1 sine.foo,NONE,1.1

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples/kernel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28193/examples/kernel

Added Files:
	Makefile.am biquad.foo fof.foo manual_mix.foo sine.foo 
Log Message:
added examples from fhg repository

--- NEW FILE: sine.foo ---
;; sine~ example

(define (fm~ carrier ratio index)
  (define mod (mul~ carrier ratio))
  (sine~ (add~ carrier (mul~ (sine~ mod) (mul~ mod index)))))

(syn 1 3 (output~ 1 (fm~ (~ 440) (~ 5) (expon~ 50 10 3))))

(play)

--- NEW FILE: biquad.foo ---
;; biquad.foo
;; 2004-07-28 rumori@banff :-)

;; convenience wrapper for c2p2zf~
;; calculate the biquad freq values

(define (biquad~ input gain pole-freq pole-reson zero-freq zero-reson)

  (define (calc-freq freq reson)
    (* 2 reson (cos (* 2 pi freq (/ 1 (foo-default-srate))))))

  (c2p2zf~
   input ; input signal
   gain ; for now 1 by 1
   (calc-freq pole-freq pole-reson) ; freq
   (- pole-reson) ; reson
   1 ; "output gain", don't know the reason why this is here
   (- (calc-freq zero-freq zero-reson))
   zero-reson))

--- NEW FILE: Makefile.am ---
# foo/elkfoo/examples/kernel/Makefile.am
# 2004 rumori

# $Id: Makefile.am,v 1.1 2004/08/12 23:15:38 rumori Exp $

NULL = 

noinst_DATA = \
	biquad.foo \
	fof.foo \
	manual_mix.foo \
	sine.foo \
	$(NULL)

--- NEW FILE: fof.foo ---
;; fof~ example

(define (fof-bank~ f0 parameter-list t a d)
  (define (helper x) (apply fof~ (list f0 (~ (car x)) (~ (cadr x)) (~ (dB->lin (caddr x))) t a d)))
  (apply add~ (map helper parameter-list)))

(define p '((609 78 0) (1000 88 -7) (2450 123 -9) (2700 128 -9)))

(syn 1 3 (output~ 1 (fof-bank~ (~ 88) p (~ 0.001) (~ 0.012) (~ 0.001))))

(play)

--- NEW FILE: manual_mix.foo ---
;; foo manual mixsnd example

;; define 2 different sweeps (left + right)
(define (make-sweep1)
  (output~ 1 (sine~ (expon~ 20 20000 3))))

(define (make-sweep2)
  (output~ 2 (mul~ (sine~ (expon~ 20000 20 3)) (bln~ (~ 500)))))

;; let's hear them separately
(syn 2 3 (make-sweep1))
(play)
(syn 2 3 (make-sweep2))
(play)

;; now the "orthodox" way: create context, soundfile, task, run task etc.
(define context1 (make-context 2))

(with-context context1 make-sweep1)

(create-soundfile "/tmp/rumori/foo1.aiff" 'short 2 48000 'aiff)

(define task1 (make-task 0 0 "/tmp/rumori/foo1.aiff" context1))

(run-task task1 3)

(play "/tmp/rumori/foo1.aiff")

;; 2nd quick
(begin
  (define context2 (make-context 2))
  (with-context context2 make-sweep2)
  (create-soundfile "/tmp/rumori/foo2.aiff" 'short 2 48000 'aiff)
  (run-task (make-task 0 0 "/tmp/rumori/foo2.aiff" context2) 3)
  (play "/tmp/rumori/foo2.aiff"))

;; archive (serialize) first context for potential later use
(with-output-to-file "/tmp/rumori/sweep1.context"
  (lambda () (write-context context1)))

;; let's render both contexts together into one file
(create-soundfile "/tmp/rumori/foomix.aiff" 'incremental 2 48000 'aiff)

(run-task (make-task 0 0 "/tmp/rumori/foomix.aiff" (copy-context context1)) 3)
(run-task (make-task 0 0 "/tmp/rumori/foomix.aiff" (copy-context context2)) 3)

(play "/tmp/rumori/foomix.aiff/mixfloat.imx")


;; and now let's subtract the second one

;; read mixinfo
(define mixinfo
  (call-with-input-file "/tmp/rumori/foomix.aiff/mix0001t" read))
mixinfo

;; read original context
(define subtract-context
  (call-with-input-file "/tmp/rumori/foomix.aiff/mix0001c" read-context))

;; render the context into a temporary file
(define ref (cadr (list-ref mixinfo 2)))
(define off (cadr (list-ref mixinfo 3)))
(define dur (/ (cadr (list-ref mixinfo 4)) (cadr (list-ref mixinfo 5))))

(create-soundfile "/tmp/rumori/subtract.aiff" 'float (context-channels subtract-context) (cadr (list-ref mixinfo 5)) 'aiff)
(run-task (make-task ref off "/tmp/rumori/subtract.aiff" subtract-context) dur)

;; sounds like the original second sweep
(play "/tmp/rumori/subtract.aiff")

;; read the file channel by channel, multiply data by -1
(define (subtract-file)
  (define subsnd (open-snd "/tmp/rumori/subtract.aiff"))
  (output~ 1 (mul~ (~ -1) (read-snd~ (snd-extract subsnd 1))))
  (output~ 2 (mul~ (~ -1) (read-snd~ (snd-extract subsnd 2)))))

;; mix inversed sound data into mixfile
(run-task (make-task ref off "/tmp/rumori/foomix.aiff" (context 2 (subtract-file))) dur)

;; done!
(play "/tmp/rumori/foomix.aiff/mixfloat.imx")

[foo-cvs] foo/elkfoo/examples/scripts Makefile.am,NONE,1.1 sine.foo,NONE,1.1 sndcat.foo,NONE,1.1

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples/scripts
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28193/examples/scripts

Added Files:
	Makefile.am sine.foo sndcat.foo 
Log Message:
added examples from fhg repository

--- NEW FILE: sine.foo ---
#!/usr/local/bin/foo

;; foo scripting example
;; (c) 2004 rumori

(if (< (length (command-line-args)) 3)
    (begin
      (format #t "usage: ~a <duration> <frequency>\n"
	      (car (command-line-args)))
      (quit)))

(define duration (string->number (list-ref (command-line-args) 1)))
(define freq (string->number (list-ref (command-line-args) 2)))

(syn 1 duration (output~ 1 (sine~ (~ freq))))
(play)

--- NEW FILE: sndcat.foo ---
#!/usr/local/bin/foo

;; sndcat: concatenate soundfiles
;; (c) 2004 rumori

(if (< (length (command-line-args)) 3)
    (begin
      (format #t "usage: ~a <dest-file> <src-file> [<src-file> ...]\n" (car (command-line-args)))
      (quit)))

(define dest-file (list-ref (command-line-args) 1))
(define source-files (cddr (command-line-args)))

(define src-snds '())
(define (dest-dur source-file)
  (if (null? source-file)
      0
      (+ (soundfile-length (car source-file))
	 (dest-dur (cdr source-file)))))

(define dest-channels (soundfile-channels (car source-files)))

(define (cat-snd-channel snd channel offset)
  (output~ channel (time offset (read-snd~ (snd-extract snd channel))))
  (if (> channel 1)
      (cat-snd-channel snd (1- channel) offset)))

(define (cat-snd-file file offset)
  (cat-snd-channel (open-snd (car file)) dest-channels offset)
  (if (not (null? (cdr file)))
      (cat-snd-file (cdr file) (+ offset (soundfile-length (car file))))))

(define (sndcat)
  (cat-snd-file source-files 0))

(define cat-context
  (context dest-channels (sndcat)))

(create-soundfile dest-file 'short dest-channels (foo-default-srate) 'aiff)

(define cat-task (make-task 0 0 dest-file cat-context))

(run-task cat-task (dest-dur source-files))

--- NEW FILE: Makefile.am ---
# foo/elkfoo/examples/scripts/Makefile.am
# 2004 rumori

# $Id: Makefile.am,v 1.1 2004/08/12 23:15:38 rumori Exp $

NULL = 

noinst_DATA = \
	sine.foo \
	sndcat.foo \
	$(NULL)

[foo-cvs] foo/elkfoo Makefile.am,1.2,1.3 configure.ac,1.10,1.11

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28193

Modified Files:
	Makefile.am configure.ac 
Log Message:
added examples from fhg repository

Index: configure.ac
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/configure.ac,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** configure.ac	10 Aug 2004 20:10:33 -0000	1.10
--- configure.ac	12 Aug 2004 23:15:37 -0000	1.11
***************
*** 289,292 ****
--- 289,295 ----
    scm/tools/mixsnd/Makefile
    scm/tools/util/Makefile
+   examples/Makefile
+   examples/kernel/Makefile
+   examples/scripts/Makefile
   ])
  

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/Makefile.am,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Makefile.am	7 Aug 2004 22:54:04 -0000	1.2
--- Makefile.am	12 Aug 2004 23:15:37 -0000	1.3
***************
*** 6,10 ****
  NULL = 
  
! SUBDIRS = include src scm
  DIST_SUBDIRS = $(SUBDIRS) autotools m4
  
--- 6,10 ----
  NULL = 
  
! SUBDIRS = include src scm examples
  DIST_SUBDIRS = $(SUBDIRS) autotools m4
  

[foo-cvs] foo/elkfoo/examples Makefile.am,NONE,1.1

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28193/examples

Added Files:
	Makefile.am 
Log Message:
added examples from fhg repository

--- NEW FILE: Makefile.am ---
# foo/elkfoo/examples/Makefile.am
# 2004 rumori

# $Id: Makefile.am,v 1.1 2004/08/12 23:15:38 rumori Exp $

NULL = 

SUBDIRS = kernel scripts

[foo-cvs] foo/elkfoo/examples/scripts - New directory

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples/scripts
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27706/scripts

Log Message:
Directory /cvsroot/foo/foo/elkfoo/examples/scripts added to the repository

[foo-cvs] foo/elkfoo/examples/kernel - New directory

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples/kernel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27706/kernel

Log Message:
Directory /cvsroot/foo/foo/elkfoo/examples/kernel added to the repository

[foo-cvs] foo/elkfoo/examples - New directory

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27644/examples

Log Message:
Directory /cvsroot/foo/foo/elkfoo/examples added to the repository

[foo-cvs] foo/elkfoo/scm oops-patch.scm,1.1,NONE

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16421

Removed Files:
	oops-patch.scm 
Log Message:
replaced by foops.scm

--- oops-patch.scm DELETED ---

[foo-cvs] foo/elkfoo/scm foops.scm,NONE,1.1

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16260

Added Files:
	foops.scm 
Log Message:
initial checkin

--- NEW FILE: foops.scm ---
;; -*-Scheme-*-
;;
;; A simple 'OOPS' package
;;
;; This is a fixed and extended version of the original
;; oops.scm provided by Elk.
;;
;; The extensions include static methods and fixe concerns
;; a problem with oops related
;; to directly calling methods in a method body without
;; employing send (something usefull to make the code
;; more readable)
;;
;; the bug consisted in the fact that a directly called
;; method would not be invoked with the proper, i.e.
;; the particular instance's environment
;;
;; simple examples *seemed* to work properly since the
;; hack-procedure-environment function used in the send
;; function permanently changes the procedure environment
;; of a method - but also most strange bugs were observed
;; due to this behavior of the original implementation
;; (instances got seemingly confused, because the directly
;; called method held still an environment of the instance
;; it was sent to last!)
;;

(require 'hack.la)

(provide 'foops)

;;
;; global variable used to store an environment stack
;; enabling nested direct method invokation
;;
;; used by define-method and send (see below)
;;

(define oops-environment-stack (list))

(define class-size 6)
(define instance-size 3)

;;; Classes and instances are represented as vectors.  The first
;;; two slots (tag and class-name) are common to classes and instances.

(define (tag v) (vector-ref v 0))
(define (set-tag! v t) (vector-set! v 0 t))

(define (class-name v) (vector-ref v 1))
(define (set-class-name! v n) (vector-set! v 1 n))

(define (class-instance-vars c) (vector-ref c 2))
(define (set-class-instance-vars! c v) (vector-set! c 2 v))

(define (class-static-methods c) (vector-ref c 5))
(define (add-class-static-method! c sm) (vector-set! c 5 (cons sm (vector-ref c 5))))
(define (static-method-known? method class) (memq method (class-static-methods class)))

(define (class-env c) (vector-ref c 3))
(define (set-class-env! c e) (vector-set! c 3 e))

(define (class-super c) (vector-ref c 4))
(define (set-class-super! c s) (vector-set! c 4 s))

(define (instance-env i) (vector-ref i 2))
(define (set-instance-env! i e) (vector-set! i 2 e))

;;; Methods are bound in the class environment.

(define (method-known? method class)
  (eval `(bound? ',method) (class-env class)))

(define (lookup-method method class)
  (eval method (class-env class)))

(define (class? c)
  (and (vector? c) (= (vector-length c) class-size) (eq? (tag c) 'class)))

(define (check-class sym c)
  (if (not (class? c))
      (error sym "argument is not a class")))

(define (instance? i)
  (and (vector? i) (= (vector-length i) instance-size)
       (eq? (tag i) 'instance)))

(define (check-instance sym i)
  (if (not (instance? i))
      (error sym "argument is not an instance")))

;;; Evaluate `body' within the scope of instance `i'.

(define-macro (with-instance i . body)
  `(unwind-protect
    (begin
      ; first push the environment stack
      (set! oops-environment-stack 
	    (cons (instance-env ,i) oops-environment-stack))
      ; invoke the method
      (eval '(begin ,@body) (instance-env ,i)))
    ; always (also in case of an error in the apply) pop the stack
    (set! oops-environment-stack (cdr oops-environment-stack))))

;;; Set a variable in an instance.

(define (instance-set! instance var val)
  (eval `(set! ,var ',val) (instance-env instance)))

;;; Set a class variable when no instance is available.

(define (class-set! class var val)
  (eval `(set! ,var ',val) (class-env class)))

;;; Convert a class variable spec into a binding suitable for a `let'.

(define (make-binding var)
  (if (symbol? var)
      (list var (quote '())) ; No initializer given; use ()
      var))                  ; Initializer has been specified; leave alone

;;; Check whether the elements of `vars' are either a symbol or
;;; of the form (symbol initializer).

(define (check-vars vars)
  (if (not (null? vars))
      (if (not (or (symbol? (car vars))
		   (and (pair? (car vars)) (= (length (car vars)) 2)
			(symbol? (caar vars)))))
	  (error 'define-class "bad variable spec: ~s" (car vars))
	  (check-vars (cdr vars)))))

;; Check whether the class var spec `v' is already a member of
;; the list `l'.  If this is the case, check whether the initializers
;; are identical.
;; allow for overloading instance var initializers in subclasses
;; a warning is printed if overloading occurs

(define (find-matching-var l v)
  (cond
   ((null? l) #f)
   ((eq? (caar l) (car v))
    (if (not (equal? (cdar l) (cdr v)))
	(begin
	  (fp-notify 'warning 'define-class "initializer overloaded" (car l) v)
	  #t)
	#t))
   (else (find-matching-var (cdr l) v))))

;;; Same as above, but don't check initializer.

(define (find-var l v)
  (cond
   ((null? l) #f)
   ((eq? (caar l) (car v)) #t)
   (else (find-var (cdr l) v))))

;;; Create a new list of class var specs by discarding all variables
;;; from `b' that are already a member of `a' (with identical initializers).

(define (join-vars a b)
  (cond
   ((null? b) a)
   ((find-matching-var a (car b)) (join-vars a (cdr b)))
   (else (join-vars (cons (car b) a) (cdr b)))))

;;; The syntax is as follows:
;;; (define-class class-name . options)
;;; options are: (super-class class-name)
;;;              (class-vars . var-specs)
;;;              (instance-vars . var-specs)
;;; each var-spec is either a symbol or (symbol initializer).
;; Changes:
;; - variables are bound in the correct order
;; - variables are bound in a letrec instead of a let*
;;

(define-macro (define-class name . args)
  (let ((class-vars) (instance-vars (list (make-binding 'self)))
	(super) (super-class-env))
    (do ((a args (cdr a))) ((null? a))
      (cond
       ((not (pair? (car a)))
	(error 'define-class "bad argument: ~s" (car a)))
       ((eq? (caar a) 'class-vars)
	(check-vars (cdar a))
	(set! class-vars (cdar a)))
       ((eq? (caar a) 'instance-vars)
	(check-vars (cdar a))
	(set! instance-vars (append instance-vars
				    (map make-binding (cdar a)))))
       ((eq? (caar a) 'super-class)
	(if (> (length (cdar a)) 1)
	    (error 'define-class "only one super-class allowed"))
	(set! super (cadar a)))
       (else
	(error 'define-class "bad keyword: ~s" (caar a)))))
    (if (not (null? super))
	(let ((class (eval super)))
	  (set! super-class-env (class-env class))
	  
	  ;; changed sequence of arguments for call to join-vars and added reversion
	  (set! instance-vars (join-vars instance-vars
					 (reverse (class-instance-vars class)))))
	
	(set! super-class-env (the-environment)))
    `(define ,name
      (let ((c (make-vector class-size '())))
	(set-tag! c 'class)
	(set-class-name! c ',name)
	(set-class-instance-vars! c ',instance-vars)
	(set-class-env! c (eval `(letrec ,(map make-binding ',class-vars)
				   (the-environment))
				,super-class-env))
	(set-class-super! c ',super)
	c))))

;;
;; define-method
;;
;; methods are encapsulated by a function with the same
;; signature as the method, this function uses the top 
;; environment of the environment stack as environment
;; to call the actual method (with the hacked environment)
;; this makes sure that no method can ever be called without
;; an explicitly hacked environment
;;

;;
;; helper function for define-method
;; fixes the problem of optional arguments
;;

(define (oops-form-proper-args-list args)
  (if (list? args)
      args
      (if (pair? args)
	  (letrec ((loop (lambda (l)
			   (if (null? (car l))
			       '()
			       (if (pair? (cdr l))
				   (cons (car l) (loop (cdr l)))
				   (cons (car l) (cons (cdr l) '())))))))
	    (loop args))
	  (list args))))

(define-macro (define-method class lambda-list . body)
  (if (not (pair? lambda-list))
      (error 'define-method "bad lambda list"))
  `(begin (check-class 'define-method ,class)
	  (let ((env (class-env ,class))
		(method (car ',lambda-list))
		(args (cdr ',lambda-list))
		(forms ',body))
	    (if (static-method-known? method ,class)
		(error 'define-method "can't overload static method nonstaticaly"))
	    (eval `(define ,method
		     (lambda ,(oops-form-proper-args-list args)
		       (apply (hack-procedure-environment!
			       (lambda ,args ,@forms)
			       (car oops-environment-stack))
			      (list ,@(oops-form-proper-args-list args)))))
		  env))))

;;
;; define define-static-method
;;
;; equal to define-method, but enters the method name to the list
;; of static functions, which can be invoked on classes (and instances)
;;

(define-macro (define-static-method class lambda-list . body)
  (if (not (pair? lambda-list))
      (error 'define-static-method "bad lambda list"))
  `(begin (check-class 'define-static-method ,class)
	  (let ((env (class-env ,class))
		(method (car ',lambda-list))
		(args (cdr ',lambda-list))
		(forms ',body))

	    ;; check for already defined method
	    (if (and (method-known? method ,class)
		     (not (static-method-known? method ,class)))
		(error 'define-static-method "can't overload nonstatic method staticaly"))
	    
	    ;; this is new for static methods
	    (add-class-static-method! ,class method)
	    
	    (eval `(define ,method
		     (lambda ,args
		       (apply (hack-procedure-environment!
			       (lambda ,(oops-form-proper-args-list args) ,@forms)
			       (car oops-environment-stack))
			      (list ,@(oops-form-proper-args-list args)))))
		  env)
	    )))


;;; All arguments of the form (instance-var init-value) are used
;;; to initialize the specified instance variable; then an
;;; initialize-instance message is sent with all remaining
;;; arguments.

(define-macro (make-instance class . args)
  `(begin
     (check-class 'make-instance ,class)
     (let* ((e (the-environment))
	    (i (make-vector instance-size #f))
	    (class-env (class-env ,class))
	    (instance-vars (class-instance-vars ,class)))
       (set-tag! i 'instance)
       (set-class-name! i ',class)
       (set-instance-env! i (eval `(let* ,instance-vars (the-environment))
				  class-env))
       (eval `(set! self ',i) (instance-env i))
       (init-instance ',args ,class i e)
       i)))

(define (init-instance args class instance env)
  (let ((other-args))
    (do ((a args (cdr a))) ((null? a))
      (if (and (pair? (car a)) (= (length (car a)) 2)
	       (find-var (class-instance-vars class) (car a)))
	  (instance-set! instance (caar a) (eval (cadar a) env))
	  (set! other-args (cons (eval (car a) env) other-args))))
    (call-init-methods class instance (reverse! other-args))))

;;
;; Call all initialize-instance methods in super-class to sub-class
;; order in the environment of `instance' with arguments `args'.
;; invokation of the initialize-instance method had to be
;; adapted to new invokation style
;;

(define (call-init-methods class instance args)
  (let ((called '()))
    (let loop ((class class))
      (if (not (null? (class-super class)))
	  (loop (eval (class-super class))))
	  (if (method-known? 'initialize-instance class)
	      (let ((method (lookup-method 'initialize-instance class)))
		(if (not (memq method called))
		    (begin
		      (unwind-protect
		       (begin
			 ; first push the environment stack
			 (set! oops-environment-stack 
			       (cons (instance-env instance) oops-environment-stack))
			 ; invoke the method
			 (apply method args))
		       ; always (also in case of an error in the apply) pop the stack
		       (set! oops-environment-stack (cdr oops-environment-stack)))
		      (set! called (cons method called)))))))))


;;
;; send
;;
;; invoking a method involves now to push the instance's
;; environment on the environment stack and to simply
;; apply the method looked up in the class environment
;; care has to be taken that the environment stack is
;; properly popped after method invokation
;;
;; additionaly static methods can be invoked on classes
;;

(define (send recv msg . args)
  (if (not (or (instance? recv) (class? recv)))
      (error 'send "receiver (~s) is neither class nor instance" recv))
  (let ((class (eval (class-name recv)))
	(env (if (instance? recv) (instance-env recv) (class-env recv))))
    (if (or (not (method-known? msg class))
	    (and (class? recv) (not (static-method-known? msg class))))
	(error 'send
	       "class '~s' doesn't understand message ~s"
	       (class-name recv)
	       `(,msg ,@args))
	(unwind-protect
	 (begin
	   ; first push the environment stack
	   (set! oops-environment-stack 
		 (cons env oops-environment-stack))
	   ; invoke the method
	   (apply (lookup-method msg class) args))
	 ; always (also in case of an error in the apply) pop the stack
	 (set! oops-environment-stack (cdr oops-environment-stack))))))

;;
;; send-super
;;
;; invokes a method defined in a specific
;; class and invokes it on the receiver
;; which has to be a direct or indirect instance
;; of class
;;

(define (send-super class recv msg . args)
  (if (not (class? class))
      (error 'send-super "class is not a class"))
  (if (not (or (instance? recv) (class? recv)))
      (error 'send-super "receiver is neither class nor instance"))
  (let ((env (if (instance? recv) (instance-env recv) (class-env recv))))
    (if (or (not (method-known? msg class))
	    (and (class? recv) (not (static-method-known? msg class))))
	(error 'send-super
	       "message not understood: ~s"
	       `(,msg ,@args))
	(unwind-protect
	 (begin
	   ; first push the environment stack
	   (set! oops-environment-stack 
		 (cons env oops-environment-stack))
	   ; invoke the method
	   (apply (lookup-method msg class) args))
	 ; always (also in case of an error in the apply) pop the stack
	 (set! oops-environment-stack (cdr oops-environment-stack))))))


;;; If the message is not understood, return #f.  Otherwise return
;;; a list of one element, the result of the method.

(define (send-if-handles instance msg . args)
  (check-instance 'send-if-handles instance)
  (let ((class (eval (class-name instance))))
    (if (not (method-known? msg class))
	#f
	(if (null? args)
	    (list (apply send (list instance msg)))
	    (list (apply send (append (list instance msg) args))))
	    )))

(define (describe-class c)
  (check-class 'describe-class c)
  (format #t "Class name:         ~s~%" (class-name c))
  (format #t "Superclass:         ~s~%"
	  (if (not (null? (class-super c)))
	      (class-super c)
	      'None))
  (format #t "Instancevars:       ")
  (do ((v (class-instance-vars c) (cdr v)) (space #f #t)) ((null? v))
      (if space
	  (format #t "                    "))
      (print (cons (caar v) (cadar v))))
  (format #t "Classvars/Methods:  ")
  (define v (car (environment->list (class-env c))))
  (if (not (null? v))
      (do ((f v (cdr f)) (space #f #t)) ((null? f))
	(if space
	    (format #t "                    "))
	(print (car f)))
      (print 'None))
      #v)

(define (describe-instance i)
  (check-instance 'describe-instance i)
  (format #t "Instance of:   ~s~%" (class-name i))
  (format #t "Instancevars:  ")
  (do ((f (car (environment->list (instance-env i))) (cdr f))
       (space #f #t)) ((null? f))
    (if space
	(format #t "               "))
    (print (car f)))
  #v)

;;
;;
;; Check type
;;
;;

(define (derived-from? object class)

  ;; define a recursive type checking
  (let* ((child #f)
	 (parent #f)
	 (ret-val #f)
	 (check-inheritance #f))

    (set! check-inheritance
	  (lambda (child parent)
		       
	    ;; compare class and type
	    (if (eq? child parent)
		(set! ret-val #t)
		
		;; recurse for parent class
		(if (not (null? child))
		    (check-inheritance (class-super (eval child)) parent)))))

    ;; check object
    (cond ((class? object) (set! child (class-name object)))
	  ((instance? object) (set! child (class-name object)))
	  ((and (symbol? object) (bound? object) (class? (eval object)))
	   (set! child object)))

    ;; check class
    (cond ((class? class) (set! parent (class-name class)))
	  ((instance? class) (set! parent (class-name class)))
	  ((and (symbol? class) (bound? class) (class? (eval class)))
	   (set! parent class)))

    ;; check inheritance
    (if (and child parent)
	(check-inheritance child parent))
    
    ;; return
    ret-val))

[foo-cvs] foo/elkfoo/scm/tools init-tools.foo,1.1,1.2

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/tools
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14903/scm/tools

Modified Files:
	init-tools.foo 
Log Message:
removed load-global

Index: init-tools.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/tools/init-tools.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** init-tools.foo	7 Aug 2004 22:53:01 -0000	1.1
--- init-tools.foo	11 Aug 2004 12:27:02 -0000	1.2
***************
*** 4,10 ****
  ;; init-tools.foo
  
- (define (global-load file)
-   (load file (global-environment)))
- 
  (autoload 'mixsnd "tools/mixsnd/mixsnd.foo")
  (autoload 'pitch "tools/pitch.foo")
--- 4,7 ----

[foo-cvs] foo/elkfoo/scm/control/processes process.foo,1.1,1.2 scheduler.foo,1.1,1.2

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control/processes
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14734/scm/control/processes

Modified Files:
	process.foo scheduler.foo 
Log Message:
adapted to foops

Index: process.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/control/processes/process.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** process.foo	7 Aug 2004 22:53:01 -0000	1.1
--- process.foo	11 Aug 2004 12:26:18 -0000	1.2
***************
*** 1,3 ****
! (require 'oops 'oops.scm)
  
  ;;;
--- 1,3 ----
! (require 'foops)
  
  ;;;

Index: scheduler.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/control/processes/scheduler.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** scheduler.foo	7 Aug 2004 22:53:01 -0000	1.1
--- scheduler.foo	11 Aug 2004 12:26:18 -0000	1.2
***************
*** 1,4 ****
! (require 'oops 'oops.scm)
! (require 'struct 'struct.scm)
  
  ;;;
--- 1,4 ----
! (require 'foops)
! (require 'struct)
  
  ;;;

[foo-cvs] foo/elkfoo/scm/control/node node.foo,1.1,1.2

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control/node
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14734/scm/control/node

Modified Files:
	node.foo 
Log Message:
adapted to foops

Index: node.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/control/node/node.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** node.foo	7 Aug 2004 22:53:01 -0000	1.1
--- node.foo	11 Aug 2004 12:26:18 -0000	1.2
***************
*** 1,3 ****
! (require 'oops)
  (define-class Node (class-vars Function-db) (instance-vars Data
  							   Args
--- 1,3 ----
! (require 'foops)
  (define-class Node (class-vars Function-db) (instance-vars Data
  							   Args

[foo-cvs] foo/elkfoo/scm/control/abstraction abstraction.foo,1.1,1.2 var-type.foo,1.1,1.2

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control/abstraction
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14734/scm/control/abstraction

Modified Files:
	abstraction.foo var-type.foo 
Log Message:
adapted to foops

Index: abstraction.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/control/abstraction/abstraction.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** abstraction.foo	7 Aug 2004 22:53:00 -0000	1.1
--- abstraction.foo	11 Aug 2004 12:26:17 -0000	1.2
***************
*** 1,3 ****
! (require 'oops)
  (define-class Abstraction (class-vars Vars			;a List
  				      Locs			;a List
--- 1,3 ----
! (require 'foops)
  (define-class Abstraction (class-vars Vars			;a List
  				      Locs			;a List

Index: var-type.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/control/abstraction/var-type.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** var-type.foo	7 Aug 2004 22:53:00 -0000	1.1
--- var-type.foo	11 Aug 2004 12:26:17 -0000	1.2
***************
*** 1,3 ****
! (require 'oops)
  (define-class Var-Type (instance-vars  Variables
  				       (checkd #f)))
--- 1,3 ----
! (require 'foops)
  (define-class Var-Type (instance-vars  Variables
  				       (checkd #f)))

[foo-cvs] foo/elkfoo/scm/control/envelope envelope.foo,1.1,1.2

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control/envelope
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14734/scm/control/envelope

Modified Files:
	envelope.foo 
Log Message:
adapted to foops

Index: envelope.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/control/envelope/envelope.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** envelope.foo	7 Aug 2004 22:53:01 -0000	1.1
--- envelope.foo	11 Aug 2004 12:26:18 -0000	1.2
***************
*** 1,3 ****
! (require 'oops)
  
  ;
--- 1,3 ----
! (require 'foops)
  
  ;

[foo-cvs] foo/elkfoo/scm/control init-control.foo,1.1,1.2

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14734/scm/control

Modified Files:
	init-control.foo 
Log Message:
adapted to foops

Index: init-control.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/control/init-control.foo,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** init-control.foo	7 Aug 2004 22:53:00 -0000	1.1
--- init-control.foo	11 Aug 2004 12:26:17 -0000	1.2
***************
*** 4,11 ****
  ;; init-control.foo
  
! (define (global-load file)
!   (load file (global-environment)))
! 
! (require 'oops)
  (require 'struct)
  
--- 4,8 ----
  ;; init-control.foo
  
! (require 'foops)
  (require 'struct)
  
***************
*** 13,19 ****
      (global-load "tools/init-tools.foo"))
  
- ;; need this?
- (global-load "oops-patch.scm")
- 
  (global-load "control/interface-lib/sp-sigpack-type.foo")
  (global-load "control/interface-lib/sp-sndpack-type.foo")
--- 10,13 ----

[foo-cvs] foo/elkfoo/scm toplevel.foo.in,1.3,1.4

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14428/scm

Modified Files:
	toplevel.foo.in 
Log Message:
changed oops into foops, added call to (inspect) in error handler, added exclude macro and global-load function

Index: toplevel.foo.in
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/toplevel.foo.in,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** toplevel.foo.in	7 Aug 2004 23:04:15 -0000	1.3
--- toplevel.foo.in	11 Aug 2004 12:24:37 -0000	1.4
***************
*** 26,30 ****
  ;;; requirements
  (require 'unix)
! (require 'oops)
  (require 'struct)
  
--- 26,30 ----
  ;;; requirements
  (require 'unix)
! (require 'foops)
  (require 'struct)
  
***************
*** 128,131 ****
--- 128,132 ----
    (lambda error-msg
      (error-print error-msg)
+     (inspect)
      (let loop ((intr-level (enable-interrupts)))
        (if (positive? intr-level)
***************
*** 180,183 ****
--- 181,200 ----
        (exit)))
  
+ ;; handy macro to "comment out" larger portions of source code in a file
+ (define exclude (macro args #t))
+ 
+ ;; global loading support
+ (define global-load-notify? #f)
+ 
+ (define (global-load file)
+   (if global-load-notify?
+     (begin
+ 	  (display "[Globloading ")
+ 	  (display file)
+ 	  (display "]")
+ 	  (newline)
+ 		))
+   (load file (global-environment)))
+ 
  ;; std list of initialization files
  (define foo-init-files

[foo-cvs] foo/elkfoo/scm Makefile.am,1.3,1.4

[Gerhard E. <gu...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2692/scm

Modified Files:
	Makefile.am 
Log Message:
changed oops-patch.scm into foops.scm, which is a new and complete oops (no need to load oops.scm before).


Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/Makefile.am,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Makefile.am	8 Aug 2004 00:33:21 -0000	1.3
--- Makefile.am	11 Aug 2004 11:26:28 -0000	1.4
***************
*** 14,18 ****
  FOO_FILES = \
  	next-compat.foo \
! 	oops-patch.scm \
  	$(NULL)
  
--- 14,18 ----
  FOO_FILES = \
  	next-compat.foo \
! 	foops.scm \
  	$(NULL)
  

[foo-cvs] foo/elkfoo bootstrap,1.2,1.3 configure.ac,1.9,1.10

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22008

Modified Files:
	bootstrap configure.ac 
Log Message:
fixed hopefully last two bugs related to autotools dir deletion

Index: configure.ac
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/configure.ac,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** configure.ac	7 Aug 2004 22:54:04 -0000	1.9
--- configure.ac	10 Aug 2004 20:10:33 -0000	1.10
***************
*** 275,279 ****
  AC_OUTPUT([
    Makefile
-   autotools/Makefile
    m4/Makefile
    include/Makefile
--- 275,278 ----

Index: bootstrap
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/bootstrap,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** bootstrap	10 Aug 2004 03:13:23 -0000	1.2
--- bootstrap	10 Aug 2004 20:10:33 -0000	1.3
***************
*** 59,64 ****
  # Remove old cruft
  rm -f aclocal.m4 configure config.guess config.log config.sub config.cache config.h.in config.h compile ltmain.sh libtool ltconfig missing mkinstalldirs depcomp install-sh INSTALL
! rm -Rf autom4te.cache
! (cd autotools && rm -f config.guess config.sub missing mkinstalldirs compile ltmain.sh depcomp install-sh)
  
  ${libtoolize} --copy --force
--- 59,64 ----
  # Remove old cruft
  rm -f aclocal.m4 configure config.guess config.log config.sub config.cache config.h.in config.h compile ltmain.sh libtool ltconfig missing mkinstalldirs depcomp install-sh INSTALL
! rm -Rf autom4te.cache autotools
! mkdir autotools
  
  ${libtoolize} --copy --force

[foo-cvs] fooelk README.FOO,1.3,1.4

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/fooelk
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19609

Modified Files:
	README.FOO 
Log Message:
postponing gnu-realtime support until better days

Index: README.FOO
===================================================================
RCS file: /cvsroot/foo/fooelk/README.FOO,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** README.FOO	10 Aug 2004 01:45:29 -0000	1.3
--- README.FOO	10 Aug 2004 19:57:08 -0000	1.4
***************
*** 68,72 ****
  really dirty configure time option:
  
! ./configure --enable-gnu-realtime \
  	--with-static-readline="/sw/lib/libreadline.a /sw/lib/libncurses.a"
  
--- 68,72 ----
  really dirty configure time option:
  
! ./configure --enable-gnu-readline \
  	--with-static-readline="/sw/lib/libreadline.a /sw/lib/libncurses.a"
  

[foo-cvs] foo/libfoo configure.ac,1.12,1.13

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/libfoo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18641/libfoo

Modified Files:
	configure.ac 
Log Message:
removed autotools/Makefile from configure templates

Index: configure.ac
===================================================================
RCS file: /cvsroot/foo/foo/libfoo/configure.ac,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** configure.ac	6 Aug 2004 05:58:20 -0000	1.12
--- configure.ac	10 Aug 2004 03:19:45 -0000	1.13
***************
*** 175,179 ****
  AC_OUTPUT([
    Makefile
-   autotools/Makefile
    m4/Makefile
    FOO/Makefile
--- 175,178 ----

[foo-cvs] foo configure.ac,1.2,1.3

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18641

Modified Files:
	configure.ac 
Log Message:
removed autotools/Makefile from configure templates

Index: configure.ac
===================================================================
RCS file: /cvsroot/foo/foo/configure.ac,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** configure.ac	7 Aug 2004 23:56:46 -0000	1.2
--- configure.ac	10 Aug 2004 03:19:45 -0000	1.3
***************
*** 23,27 ****
  AC_OUTPUT([
    Makefile
-   autotools/Makefile
   ])
  
--- 23,26 ----

[foo-cvs] foo bootstrap,1.3,1.4

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17970

Modified Files:
	bootstrap 
Log Message:
corrected problem with autotools dir

Index: bootstrap
===================================================================
RCS file: /cvsroot/foo/foo/bootstrap,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** bootstrap	9 Aug 2004 17:54:54 -0000	1.3
--- bootstrap	10 Aug 2004 03:16:10 -0000	1.4
***************
*** 57,62 ****
  # Remove old cruft
  rm -f aclocal.m4 configure config.guess config.log config.sub config.cache compile missing mkinstalldirs install-sh INSTALL
! rm -Rf autom4te.cache
! (cd autotools && rm -f config.guess config.sub missing mkinstalldirs compile install-sh)
  
  aclocal${amvers}
--- 57,62 ----
  # Remove old cruft
  rm -f aclocal.m4 configure config.guess config.log config.sub config.cache compile missing mkinstalldirs install-sh INSTALL
! rm -Rf autom4te.cache autotools
! mkdir autotools
  
  aclocal${amvers}