Commit e5686186 authored by IOhannes m zmölnig's avatar IOhannes m zmölnig

New upstream version 17.1

parent 0b84e302
Snd change log Snd change log
16-Jan: Snd 17.1.
2017 ----------------------------------------------------------------
5-Dec: Snd 17.0. 5-Dec: Snd 17.0.
24-Oct: Snd 16.9. 24-Oct: Snd 16.9.
6-Sep: Snd 16.8. 6-Sep: Snd 16.8.
...@@ -13,7 +17,7 @@ Snd change log ...@@ -13,7 +17,7 @@ Snd change log
20-Feb: Snd 16.3. 20-Feb: Snd 16.3.
11-Jan-16: Snd 16.2. 11-Jan-16: Snd 16.2.
2015 ---------------------------------------------------------------- 2016 ----------------------------------------------------------------
30-Nov: Snd 16.1. 30-Nov: Snd 16.1.
19-Oct: Snd 16.0. 19-Oct: Snd 16.0.
......
Snd 17.0. Snd 17.1:
Tito Latini fixed many bugs, especially in save-state and snd-mix, *rootlet-redefinition-hook*
and made it possible to move dialogs between desktops in Motif. {apply_values} -> apply-values, {list} -> list-values, {append} -> append
a case clause without a result returns the selector
(*s7* 'autoloading) to turn the autoloader on and off
sandbox in stuff.scm for protected evaluation
Mike Scholz updated snd-test.fs|rb and made clm.rb compatible in clm: clm.asd updated by Tito Latini.
with the latest Ruby.
checked: gtk 3.22.2|3|4, gtk 3.89.1, sbcl 1.3.11|12. checked: gsl 2.2.1, gtk 3.89.2, sbcl 1.13.3, FreeBSD 11.0
Thanks!: Mike Scholz, Anders Vinjar, Tito Latini, Kjetil Matheussen, Thanks!: Tito Latini, Kjetil Matheussen, Juan Cerillo, Mike Scholz.
IOhannes m zmölnig.
This diff is collapsed.
...@@ -865,7 +865,6 @@ ...@@ -865,7 +865,6 @@
(define-animal (spring-peeper beg amp) (define-animal (spring-peeper beg amp)
(let ((dur 0.17) (let ((dur 0.17)
(pause 0.23) (pause 0.23)
(dur2 .13)
(index (hz->radians (* 0.1 2900)))) (index (hz->radians (* 0.1 2900))))
;; first note ;; first note
(let ((start (seconds->samples beg)) (let ((start (seconds->samples beg))
...@@ -884,7 +883,8 @@ ...@@ -884,7 +883,8 @@
(+ (* 0.2 (oscil gen2 (* 0.5 frq))) (+ (* 0.2 (oscil gen2 (* 0.5 frq)))
(* 1.5 (oscil gen2a frq)))))))))) ; end is not quite right (original has a catch) (* 1.5 (oscil gen2a frq)))))))))) ; end is not quite right (original has a catch)
;; second note ;; second note
(let ((start2 (+ stop (seconds->samples pause)))) (let ((start2 (+ stop (seconds->samples pause)))
(dur2 .13))
(let ((stop2 (+ start2 (seconds->samples dur2))) (let ((stop2 (+ start2 (seconds->samples dur2)))
(ampf2 (make-env '(0 0 .125 .8 1 .9 2 .7 4 1 10 0) :base .1 :duration dur2 :scaler (* .4 amp))) (ampf2 (make-env '(0 0 .125 .8 1 .9 2 .7 4 1 10 0) :base .1 :duration dur2 :scaler (* .4 amp)))
(frqf2 (make-env '(0 0 2 1 3 .75) :duration dur2 :base .03 :scaler (hz->radians 300))) (frqf2 (make-env '(0 0 2 1 3 .75) :duration dur2 :base .03 :scaler (hz->radians 300)))
......
...@@ -11,60 +11,66 @@ ...@@ -11,60 +11,66 @@
(set! auto-saving #f)))) (set! auto-saving #f))))
(define auto-save (define auto-save
(let ((documentation "(auto-save) starts watching files, automatically saving backup copies as edits accumulate")) (let ((documentation "(auto-save) starts watching files, automatically saving backup copies as edits accumulate")
(lambda ()
(define (auto-save-temp-name snd) (auto-save-temp-name
(string-append (if (and (string? *temp-dir*) (lambda (snd)
(> (length *temp-dir*) 0)) (string-append (if (and (string? *temp-dir*)
(string-append *temp-dir* "/") (> (length *temp-dir*) 0))
"") (string-append *temp-dir* "/")
"#" (short-file-name snd) "#")) "")
"#" (short-file-name snd) "#")))
(define (clear-unsaved-edits snd)
(set! (sound-property 'auto-save snd) 0))
(define (auto-save-open-func snd) (clear-unsaved-edits
(let ((temp-file (auto-save-temp-name snd))) (lambda (snd)
(if (and (file-exists? temp-file) (set! (sound-property 'auto-save snd) 0))))
(< (file-write-date (file-name snd)) (file-write-date temp-file)))
(snd-warning (format #f "auto-saved version of ~S (~S) is newer"
(short-file-name snd)
temp-file)))
(do ((i 0 (+ 1 i)))
((= i (channels snd)))
(if (null? (hook-functions (edit-hook snd i)))
(hook-push (edit-hook snd i) (lambda (hook)
(let ((snd (hook 'snd)))
(set! (sound-property 'auto-save snd) (+ 1 (sound-property 'auto-save snd))))))))
(clear-unsaved-edits snd)))
(define (auto-save-done snd) (let ((auto-save-open-func
(let ((temp-file (auto-save-temp-name snd))) (lambda (snd)
(if (file-exists? temp-file) (let ((temp-file (auto-save-temp-name snd)))
(delete-file temp-file)) (if (and (file-exists? temp-file)
(clear-unsaved-edits snd))) (< (file-write-date (file-name snd)) (file-write-date temp-file)))
(snd-warning (format #f "auto-saved version of ~S (~S) is newer"
(short-file-name snd)
temp-file)))
(do ((i 0 (+ 1 i)))
((= i (channels snd)))
(if (null? (hook-functions (edit-hook snd i)))
(hook-push (edit-hook snd i) (lambda (hook)
(let ((snd (hook 'snd)))
(set! (sound-property 'auto-save snd) (+ 1 (sound-property 'auto-save snd))))))))
(clear-unsaved-edits snd))))
(define (auto-save-func) (auto-save-done
(if auto-saving (lambda (snd)
(begin (let ((temp-file (auto-save-temp-name snd)))
(for-each (lambda (snd) (if (file-exists? temp-file)
(if (cond ((sound-property 'auto-save snd) => positive?) (else #f)) (delete-file temp-file))
(let ((save-name (auto-save-temp-name snd))) (clear-unsaved-edits snd)))))
(status-report (string-append "auto-saving as " save-name "...") snd)
(in 3000 (lambda () (status-report "" snd)))
(save-sound-as save-name snd)
(clear-unsaved-edits snd))))
(sounds))
(in (floor (* 1000 auto-save-interval)) auto-save-func))))
(if (not (member auto-save-done (hook-functions close-hook))) (letrec ((auto-save-func
(begin (lambda ()
(for-each auto-save-open-func (sounds)) (if auto-saving
(hook-push after-open-hook (lambda (hook) (auto-save-open-func (hook 'snd)))) (begin
(hook-push close-hook (lambda (hook) (auto-save-done (hook 'snd)))) (for-each (lambda (snd)
(hook-push save-hook (lambda (hook) (auto-save-done (hook 'snd)))) (if (cond ((sound-property 'auto-save snd) => positive?) (else #f))
(hook-push exit-hook (lambda (hook) (for-each auto-save-done (sounds)))))) (let ((save-name (auto-save-temp-name snd)))
(set! auto-saving #t) (status-report (string-append "auto-saving as " save-name "...") snd)
(in (floor (* 1000 auto-save-interval)) auto-save-func)))) (in 3000 (lambda () (status-report "" snd)))
(save-sound-as save-name snd)
(clear-unsaved-edits snd))))
(sounds))
(in (floor (* 1000 auto-save-interval)) auto-save-func))))))
(lambda ()
(if (not (member auto-save-done (hook-functions close-hook)))
(begin
(for-each auto-save-open-func (sounds))
(hook-push after-open-hook (lambda (hook) (auto-save-open-func (hook 'snd))))
(hook-push close-hook (lambda (hook) (auto-save-done (hook 'snd))))
(hook-push save-hook (lambda (hook) (auto-save-done (hook 'snd))))
(hook-push exit-hook (lambda (hook) (for-each auto-save-done (sounds))))))
(set! auto-saving #t)
(in (floor (* 1000 auto-save-interval)) auto-save-func))))))
(auto-save) (auto-save)
This diff is collapsed.
...@@ -271,11 +271,6 @@ ...@@ -271,11 +271,6 @@
(error (format #f "can't allocate ~A" color)) (error (format #f "can't allocate ~A" color))
(.pixel col)))) (.pixel col))))
(define (set-flabel label value)
(let ((s1 (XmStringCreate (format #f "~5,3F" value) XmFONTLIST_DEFAULT_TAG)))
(XtVaSetValues label (list XmNlabelString s1))
(XmStringFree s1)))
(XtSetValues shell (list XmNtitle "FM Forever!")) (XtSetValues shell (list XmNtitle "FM Forever!"))
(let* ((light-blue (get-color sliderback)) (let* ((light-blue (get-color sliderback))
(form (XtCreateManagedWidget "form" xmFormWidgetClass shell (form (XtCreateManagedWidget "form" xmFormWidgetClass shell
...@@ -447,7 +442,12 @@ ...@@ -447,7 +442,12 @@
(high-index 2.0) (high-index 2.0)
(which-play 0) (which-play 0)
(proc #f) (proc #f)
(func #f)) (func #f)
(set-flabel
(lambda (label value)
(let ((s1 (XmStringCreate (format #f "~5,3F" value) XmFONTLIST_DEFAULT_TAG)))
(XtVaSetValues label (list XmNlabelString s1))
(XmStringFree s1)))))
(define (tempo-callback w c i) (define (tempo-callback w c i)
(set! ctempo (+ low-tempo (* (.value i) (/ (- high-tempo low-tempo) 100.0)))) (set! ctempo (+ low-tempo (* (.value i) (/ (- high-tempo low-tempo) 100.0))))
......
...@@ -177,30 +177,29 @@ ...@@ -177,30 +177,29 @@
;;; -------- nsin -------- ;;; -------- nsin --------
(defgenerator (big-nsin (defgenerator (big-nsin
:make-wrapper :make-wrapper (letrec ((ns (lambda (x n)
(lambda (g) (let* ((a2 (/ x 2))
(letrec ((ns (lambda (x n) (den (sin a2)))
(let* ((a2 (/ x 2)) (if (= den 0.0)
(den (sin a2))) 0.0
(if (= den 0.0) (/ (* (sin (* n a2))
0.0 (sin (* (+ n 1) a2)))
(/ (* (sin (* n a2)) den)))))
(sin (* (+ n 1) a2))) (find-scaler (lambda (n lo hi)
den))))) (let ((mid (/ (+ lo hi) 2))
(find-scaler (lambda (n lo hi) (ylo (ns lo n))
(let ((mid (/ (+ lo hi) 2)) (yhi (ns hi n)))
(ylo (ns lo n)) (if (< (abs (- yhi ylo)) 1e-12)
(yhi (ns hi n))) (ns mid n)
(if (< (abs (- yhi ylo)) 1e-12) (find-scaler n (if (> ylo yhi)
(ns mid n) (values lo mid)
(find-scaler n (if (> ylo yhi) (values mid hi))))))))
(values lo mid) (lambda (g)
(values mid hi)))))))) (if (<= (g 'n) 0)
(if (<= (g 'n) 0) (set! (g 'n) 1))
(set! (g 'n) 1)) (set! (g 'r) (/ 1.0 (find-scaler (g 'n) 0.0 (/ pi (+ (g 'n) 1/2)))))
(set! (g 'r) (/ 1.0 (find-scaler (g 'n) 0.0 (/ pi (+ (g 'n) 1/2))))) (set! (g 'frequency) (big-hz->radians (g 'frequency)))
(set! (g 'frequency) (big-hz->radians (g 'frequency))) g)))
g)))
(frequency *clm-default-frequency*) (frequency *clm-default-frequency*)
(n 1) (n 1)
(angle 0.0) (angle 0.0)
......
...@@ -22,28 +22,30 @@ ...@@ -22,28 +22,30 @@
Anything other than .5 = longer decay. Must be between 0 and less than 1.0. Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
'lossfact' can be used to shorten decays. Most useful values are between .8 and 1.0. (with-sound () (pluck 0 1 330 .3 .7 .995))" 'lossfact' can be used to shorten decays. Most useful values are between .8 and 1.0. (with-sound () (pluck 0 1 330 .3 .7 .995))"
(define (tuneIt f s1) (define tuneIt
(let ((getOptimumC (lambda (S o p)
(define (getOptimumC S o p) (let* ((pa (* (/ 1.0 o)
(let* ((pa (* (/ 1.0 o) (atan (* S (sin o)) (- (+ 1.0 (* S (cos o))) S)))) (atan (* S (sin o))
(tmpInt (floor (- p pa))) (- (+ 1.0 (* S (cos o))) S))))
(pc (- p pa tmpInt))) (tmpInt (floor (- p pa)))
(if (< pc .1) (pc (- p pa tmpInt)))
(do () (if (< pc .1)
((>= pc .1)) (do ()
(set! tmpInt (- tmpInt 1)) ((>= pc .1))
(set! pc (+ pc 1.0)))) (set! tmpInt (- tmpInt 1))
(list tmpInt (/ (- (sin o) (sin (* o pc))) (sin (+ o (* o pc))))))) (set! pc (+ pc 1.0))))
(list tmpInt (/ (- (sin o) (sin (* o pc)))
(let ((p (/ *clm-srate* f)) ;period as float (sin (+ o (* o pc)))))))))
(s (if (= s1 0.0) 0.5 s1)) (lambda (f s1)
(o (hz->radians f))) (let ((p (/ *clm-srate* f)) ;period as float
(let ((vals (getOptimumC s o p)) (s (if (= s1 0.0) 0.5 s1))
(vals1 (getOptimumC (- 1.0 s) o p))) (o (hz->radians f)))
(if (and (not (= s 1/2)) (let ((vals (getOptimumC s o p))
(< (abs (cadr vals)) (abs (cadr vals1)))) (vals1 (getOptimumC (- 1.0 s) o p)))
(list (- 1.0 s) (cadr vals) (car vals)) (if (and (not (= s 1/2))
(list s (cadr vals1) (car vals1)))))) (< (abs (cadr vals)) (abs (cadr vals1))))
(list (- 1.0 s) (cadr vals) (car vals))
(list s (cadr vals1) (car vals1))))))))
(let ((vals (tuneIt freq weighting))) (let ((vals (tuneIt freq weighting)))
(let ((wt0 (car vals)) (let ((wt0 (car vals))
...@@ -85,8 +87,8 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0. ...@@ -85,8 +87,8 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
(definstrument (vox beg dur freq amp ampfun freqfun freqscl phonemes formant-amps formant-indices (vibscl .1) (deg 0) (pcrev 0)) (definstrument (vox beg dur freq amp ampfun freqfun freqscl phonemes formant-amps formant-indices (vibscl .1) (deg 0) (pcrev 0))
(define (vox-fun phons which) (define vox-fun
(let ((formants (let ((formants ; formant center frequencies for a male speaker
'((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410) '((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410)
(UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410) (UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410)
(U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690) (U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690)
...@@ -98,21 +100,18 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0. ...@@ -98,21 +100,18 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
(T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400) (T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400)
(TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000) (TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000)
(V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500) (V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500)
(ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400)))) (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400)))
;;formant center frequencies for a male speaker (find-phoneme (lambda (phoneme forms)
(do ((forms forms (cdr forms)))
(define (find-phoneme phoneme forms) ((eq? phoneme (caar forms))
(do ((phoneme phoneme) (cdar forms))))))
(forms forms (cdr forms))) (lambda (phons which)
((eq? phoneme (caar forms)) (let ((f1 ())
(cdar forms)))) (len (length phons)))
(do ((i 0 (+ i 2)))
(let ((f1 ()) ((>= i len))
(len (length phons))) (set! f1 (cons ((find-phoneme (phons (+ i 1)) formants) which) (cons (phons i) f1))))
(do ((i 0 (+ i 2))) (reverse f1)))))
((>= i len))
(set! f1 (cons ((find-phoneme (phons (+ i 1)) formants) which) (cons (phons i) f1))))
(reverse f1))))
(let ((start (seconds->samples beg)) (let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur))) (end (seconds->samples (+ beg dur)))
...@@ -2031,11 +2030,11 @@ is a physical model of a flute: ...@@ -2031,11 +2030,11 @@ is a physical model of a flute:
(set! la ca) (set! la ca)
(set! ca ra) (set! ca ra)
(set! ra (fdr k)) (set! ra (fdr k))
(when (and (> ca .001) ; lowest-magnitude (unless (or (<= ca 0.001) ; lowest-magnitude
(> ca ra) (<= ca ra)
(> ca la) (<= ca la)
(not (zero? ra)) (zero? ra)
(not (zero? la))) (zero? la))
;; found a local maximum above the current threshold (its bin number is k-1) ;; found a local maximum above the current threshold (its bin number is k-1)
(let ((logla (log la 10.0)) (let ((logla (log la 10.0))
(logca (log ca 10.0)) (logca (log ca 10.0))
......
...@@ -10330,7 +10330,7 @@ static char *describe_file_to_sample(mus_any *ptr) ...@@ -10330,7 +10330,7 @@ static char *describe_file_to_sample(mus_any *ptr)
rdin *gen = (rdin *)ptr; rdin *gen = (rdin *)ptr;
char *describe_buffer; char *describe_buffer;
describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE); describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE);
snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s %s", snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s \"%s\"",
mus_name(ptr), mus_name(ptr),
gen->file_name); gen->file_name);
return(describe_buffer); return(describe_buffer);
...@@ -10806,7 +10806,7 @@ static char *describe_file_to_frample(mus_any *ptr) ...@@ -10806,7 +10806,7 @@ static char *describe_file_to_frample(mus_any *ptr)
rdin *gen = (rdin *)ptr; rdin *gen = (rdin *)ptr;
char *describe_buffer; char *describe_buffer;
describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE); describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE);
snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s %s", snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s \"%s\"",
mus_name(ptr), mus_name(ptr),
gen->file_name); gen->file_name);
return(describe_buffer); return(describe_buffer);
...@@ -10922,7 +10922,7 @@ static char *describe_sample_to_file(mus_any *ptr) ...@@ -10922,7 +10922,7 @@ static char *describe_sample_to_file(mus_any *ptr)
rdout *gen = (rdout *)ptr; rdout *gen = (rdout *)ptr;
char *describe_buffer; char *describe_buffer;
describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE); describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE);
snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s %s", snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s \"%s\"",
mus_name(ptr), mus_name(ptr),
gen->file_name); gen->file_name);
return(describe_buffer); return(describe_buffer);
...@@ -11583,7 +11583,7 @@ static char *describe_frample_to_file(mus_any *ptr) ...@@ -11583,7 +11583,7 @@ static char *describe_frample_to_file(mus_any *ptr)
rdout *gen = (rdout *)ptr; rdout *gen = (rdout *)ptr;
char *describe_buffer; char *describe_buffer;
describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE); describe_buffer = (char *)malloc(DESCRIBE_BUFFER_SIZE);
snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s %s", snprintf(describe_buffer, DESCRIBE_BUFFER_SIZE, "%s \"%s\"",
mus_name(ptr), mus_name(ptr),
gen->file_name); gen->file_name);
return(describe_buffer); return(describe_buffer);
......
...@@ -1199,11 +1199,14 @@ ...@@ -1199,11 +1199,14 @@
(let ((start (seconds->samples beg)) (let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur))) (end (seconds->samples (+ beg dur)))
(cr (make-oscil freq carrier-phase)) (cr (make-oscil freq carrier-phase))
(n (length mc-ratios))) (n (length mc-ratios))
(define (interleave a b) (interleave (lambda (a b)
(let ((lst ())) (let ((lst ()))
(for-each (lambda (x y) (set! lst (cons (hz->radians (* freq x y)) (cons x lst)))) a b) (for-each (lambda (x y)
(reverse lst))) (set! lst (cons (hz->radians (* freq x y))
(cons x lst))))
a b)
(reverse lst)))))
(if (and (apply and (map integer? mc-ratios)) (if (and (apply and (map integer? mc-ratios))
(apply and (map zero? mod-phases))) ; use polyoid if any not 0.0 (apply and (map zero? mod-phases))) ; use polyoid if any not 0.0
(let ((fm (make-polywave freq (interleave mc-ratios indexes) mus-chebyshev-second-kind))) (let ((fm (make-polywave freq (interleave mc-ratios indexes) mus-chebyshev-second-kind)))
......
...@@ -193,16 +193,6 @@ ...@@ -193,16 +193,6 @@
(define (checker type) (define (checker type)
(find-handler type cadr)) (find-handler type cadr))
(define* (cload->signature type rtn)
(case (C-type->s7-type type)
((real) (if rtn 'float? 'real?))
((integer) 'integer?)
((string) 'string?)
((boolean) 'boolean?)
((character) 'char?)
((c_pointer) 'c-pointer?)
(else #t)))
(define (signature->pl type) (define (signature->pl type)
(case type (case type
((integer?) #\i) ((integer?) #\i)
...@@ -234,42 +224,49 @@ ...@@ -234,42 +224,49 @@
(cons 'char? 0) (cons 'string? 0) (cons 'c-pointer? 0) (cons 't 0))) (cons 'char? 0) (cons 'string? 0) (cons 'c-pointer? 0) (cons 't 0)))
(signatures (make-hash-table))) (signatures (make-hash-table)))
(define (make-signature rtn args) (define make-signature
(let ((cload->signature
(define (compress sig) (lambda* (type rtn)
(do ((sig sig (cdr sig))) (case (C-type->s7-type type)
((not (and (pair? sig) ((real) (if rtn 'float? 'real?))
(pair? (cdr sig)) ((integer) 'integer?)
(eq? (car sig) (cadr sig)))) ((string) 'string?)
sig))) ((boolean) 'boolean?)
((character) 'char?)
(let ((sig (list (cload->signature rtn #t))) ((c_pointer) 'c-pointer?)
(cyclic #f)) (else #t)))))
(for-each (lambda (rtn args)
(lambda (arg) (let ((sig (list (cload->signature rtn #t)))
(set! sig (cons (cload->signature arg) sig))) (cyclic #f))
args) (for-each
(let ((len (length sig))) (lambda (arg)
(set! sig (compress sig)) (set! sig (cons (cload->signature arg) sig)))
(set! cyclic (not (= len (length sig))))) args)
(set! sig (reverse sig)) (let ((len (length sig)))
(unless (signatures sig) ; it's not in our collection yet (set! sig (do ((sig sig (cdr sig)))
(let ((pl (make-string (+ (if cyclic 4 3) (length sig)))) ((not (and (pair? sig)
(loc (if cyclic 4 3))) (pair? (cdr sig))
(set! (pl 0) #\p) (eq? (car sig) (cadr sig))))
(if cyclic sig)))
(begin (set! (pl 1) #\c) (set! (pl 2) #\l) (set! (pl 3) #\_)) (set! cyclic (not (= len (length sig)))))
(begin (set! (pl 1) #\l) (set! (pl 2) #\_))) (set! sig (reverse sig))
(for-each (unless (signatures sig) ; it's not in our collection yet
(lambda (typer) (let ((pl (make-string (+ (if cyclic 4 3) (length sig))))
(set! (pl loc) (signature->pl typer)) (loc (if cyclic 4 3)))
(let ((count (or (assq typer sig-symbols) (set! (pl 0) #\p)
(assq 't sig-symbols)))) (if cyclic
(set-cdr! count (+ (cdr count) 1))) (begin (set! (pl 1) #\c) (set! (pl 2) #\l) (set! (pl 3) #\_))
(set! loc (+ loc 1))) (begin (set! (pl 1) #\l) (set! (pl 2) #\_)))
sig) (for-each
(set! (signatures sig) pl))) (lambda (typer)
sig)) (set! (pl loc) (signature->pl typer))
(let ((count (or (assq typer sig-symbols)
(assq 't sig-symbols))))
(set-cdr! count (+ (cdr count) 1)))
(set! loc (+ loc 1)))
sig)
(set! (signatures sig) pl)))
sig))))
(define (initialize-c-file) (define (initialize-c-file)
;; C header stuff ;; C header stuff
...@@ -573,47 +570,48 @@ ...@@ -573,47 +570,48 @@
(system (format #f "gcc ~A -shared -o ~A ~A ~A" (system (format #f "gcc ~A -shared -o ~A ~A ~A"
o-file-name so-file-name *cload-ldflags* ldflags))))) o-file-name so-file-name *cload-ldflags* ldflags)))))
(define (handle-declaration func) (define handle-declaration
(let ()
(define (add-one-constant type name) (define (add-one-constant type name)
;; C constant -> scheme ;; C constant -> scheme
(let ((c-type (if (pair? type) (cadr type) type))) (let ((c-type (if (pair? type) (cadr type) type)))
(if (symbol? name) (if (symbol? name)
(set! constants (cons (list c-type (symbol->string (collides? name))) constants)) (set! constants (cons (list c-type (symbol->string (collides? name))) constants))
(for-each (for-each
(lambda (c) (lambda (c)
(set! constants (cons (list c-type (symbol->string (collides? c))) constants))) (set! constants (cons (list c-type (symbol->string (collides? c))) constants)))
name)))) name))))
(define (add-one-macro type name) (define (add-one-macro type name)
;; C macro (with definition check) -> scheme ;; C macro (with definition check) -> scheme
(let ((c-type (if (pair? type) (cadr type) type))) (let ((c-type (if (pair? type) (cadr type) type)))
(if (symbol? name) (if (symbol? name)
(set! macros (cons (list c-type (symbol->string (collides? name))) macros)) (set! macros (cons (list c-type (symbol->string (collides? name))) macros))
(for-each (for-each
(lambda (c) (lambda (c)
(set! macros (cons (list c-type (symbol->string (collides? c))) macros))) (set! macros (cons (list c-type (symbol->string (collides? c))) macros)))
name)))) name))))
(define (check-doc func-data) (define (check-doc func-data)
(let ((doc (caddr func-data))) (let ((doc (caddr func-data)))
(if (and (string? doc) (if (and (string? doc)
(> (length doc) 0)) (> (length doc) 0))
func-data func-data
(append (list (car func-data) (cadr func-data) (car func-data)) (cdddr func-data))))) (append (list (car func-data) (cadr func-data) (car func-data)) (cdddr func-data)))))
;; functions (lambda (func)
(if (>= (length func) 3) ;; functions
(apply add-one-function func) (if (>= (length func) 3)
(case (car func) (apply add-one-function func)
((in-C) (format p "~A~%" (cadr func))) (case (car func)
((C-init) (set! inits (cons (cadr func) inits))) ((in-C) (format p "~A~%" (cadr func)))
((C-macro) (apply add-one-macro (cadr func))) ((C-init) (set! inits (cons (cadr func) inits)))
((C-function) (collides? (caadr func)) (set! functions (cons (check-doc (cadr func)) functions))) ((C-macro) (apply add-one-macro (cadr func)))
(else (apply add-one-constant func))))) ((C-function) (collides? (caadr func)) (set! functions (cons (check-doc (cadr func)) functions)))
(else (apply add-one-constant func)))))))
;; this is the body of c-define ;; c-define-1 (called in c-define macro above)
(unless (and output-name (unless (and output-name
(file-exists? c-file-name) (file-exists? c-file-name)
(file-exists? so-file-name) (file-exists? so-file-name)
...@@ -639,11 +637,6 @@ ...@@ -639,11 +637,6 @@
(load so-file-name new-env))))) (load so-file-name new-env)))))
;;; backwards compatibility
(define define-c-function c-define)