Autres/audacity
1
0
Fork 0
mirror of https://github.com/cookiengineer/audacity synced 2025-05-05 14:18:53 +02:00
Code Issues Releases Wiki Activity
audacity/lib-src/libnyquist/nyquist/tran/writemake.lsp
ra 58caf78a86 Move library tree where it belongs
2010-01-24 09:19:39 +00:00

935 lines
34 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;************
;; writemake.lsp -- generate the sound create routine
;;************
;;************
;; Change Log
;; Date | Change
;;-----------+--------------------
;; 17-Dec-91 | [1.1] <jmn> Created
;; 17-Dec-91 | [1.1] <jmn> return sound_create(...) cast type to correct
;; | type
;; 21-Dec-91 | [1.2] <jmn> added start-time, default 0.0
;; 21-Dec-91 | [1.2] <jmn> prefix creation local variables with C_
;; 13-Jan-92 | [1.2] <jmn> reformatted and recommented
;; 3-May-99 | <rbd> modified toss_fetch code to retain proper t0
;;************
;; check-for-no-interpolation - if you see an "s", make sure there
;; is a corresponding "n", if not use "s" to cover the "n" case. And vice versa.
;;
(defun check-for-no-interpolation (encoding interpolation-rationale stream)
; *cfni-output* used to keep track of newline output
(setf *cfni-output* nil)
(check-for-no-interpolation-1 encoding 0 interpolation-rationale stream))
;; Hint: this algorithm constructs the 2^n variations by substituting
;; (or not) 'n' for 's' whereever s'es occur. The search is cut off
;; however, when an altered string is found in the encoding-list, which
;; tells what cases are handled directly.
;;
;; Wow, returning to the description above after several months, I couldn't make
;; heads or tails of it, and I wrote it! Here's another perhaps better, description:
;;
;; We generated various _fetch routines that differ in their assumptions about how to
;; access signal arguments. There are (now) 4 variations: NONE, SCALE, INTERP, and
;; RAMP. All 4^N combinations of these are generated initially, but many combinations
;; are deleted before any code is generated. Reasons for removing a combination include
;; the use of symetry, linearity, and simply the promise that input arguments will be
;; interpolated externally. In most of these cases, combinations are removed because
;; they cannot occur in practice. But in others, combinations are removed because they
;; should be handled by different code. For example, an input signal matching the output
;; sample rate and with a scale factor of 1 is normally handled by NONE style
;; "interpolation". Note: "interpolation" is used throughout this code, but a better term
;; would be "access method," because no interpolation is involved in the NONE and
;; SCALE variants. The inner loop access code for NONE style is something like "*s++".
;; However, an input signal suitable for NONE style interpolation can also be handled
;; by SCALE style interpolation (which looks something like "(*s++ * s_scale)", i.e.
;; an extra multiplication is required. If the attribute INTERNAL-SCALING is used,
;; then the scale factor does not actually appear at the access point because it has been
;; factored into a filter coefficient or some other factor, saving the multiply.
;; Alternatively, the ALWAYS-SCALE attribute can specify that there is little to be
;; gained by saving a multiply. In these cases, we want to handle NONE style signals
;; with SCALE style interpolation. Let's run through these possibilities again and
;; describe how they are handled:
;;
;; ALWAYS-SCALE: here we delete the NONE variant(s) and only generate fetch
;; routines that have scaling code in them. When we get an actual parameter with
;; a scale factor of 1 (implying NONE interpolation), we handle it with the SCALE
;; fetch routine.
;; INTERNAL-SCALING: here we generate NONE fetch routines because the
;; scale factor is taken care of elsewhere in the code, e.g. in a filter coefficient.
;; LINEAR: here, the scale factor of the actual argument becomes a scale factor
;; on the output (part of the data structure), deferring multiplies until later. We
;; then modify the argument scale factor to 1, and NONE style interpolation applies.
;; There is no need to generate SCALE style routines, because there will never be
;; any need for them.
;;
;; For a given signal parameter, these 3 cases are mutually exclusive.
;;
;; Looking at these three cases, we see that sometimes there will be SCALE style
;; routines handling NONE arguments, sometimes NONE style routines handling
;; SCALE arguments, and sometimes NONE style routines because there will
;; never be a need for SCALE.
;; This code is going to generate labels so that other fetch routines
;; handle the "missing" ones.
;; To do this, we generate extra labels in the case
;; statement that selects the fetch routine (interpolation is in the inner loop in the
;; fetch routine. For example, we might generate this code:
;; ...
;; case INTERP_nn:
;; case INTERP_sn:
;; case INTERP_ns:
;; case INTERP_ss: susp->susp.fetch = tonev_ss_fetch; break;
;; ...
;; Here, a single fetch routine (tonev_ss_fetch) handles all variations of NONE and
;; SCALE (n and s) types of the two signal arguments. The basic rule is: if you did not
;; generate a fetch routine for the NONE case, then handle it with the SCALE case, and
;; if you did not generate a fetch routine for the SCALE case, handle it with the NONE
;; case.
;;
;; The algorithm uses the list interpolation-rationale, which lists for each sound
;; parameter one of {NIL, LINEAR, ALWAYS-SCALE, INTERNAL-SCALING}.
;; Using this list, the code enumerates all the possible cases that might be handled
;; by the current fetch routine (represented by the "encoding" parameter).
;; This is a recursive algorithm because, if there are n SCALE type parameters, then
;; there are 2^N possible variations to enumerate. (E.g. look at the 4 variations in
;; the code example above.)
;;
;;
(defun check-for-no-interpolation-1 (encoding index
interpolation-rationale stream)
(cond ((= index (length encoding))
(display "check-for-no-interpolation output" encoding)
; see if we need a newline (*cfni-output* is initially nil)
(if *cfni-output* (format stream "/* handled below */~%"))
(setf *cfni-output* t)
(format stream " case INTERP_~A: " encoding))
(t
(let ((ch (char encoding index)))
(display "cfni" index ch)
(cond ((eql ch #\s)
(let ((new-encoding (strcat (subseq encoding 0 index)
"n"
(subseq encoding (1+ index)))))
(cond ((eq (nth index interpolation-rationale) 'ALWAYS-SCALE)
(check-for-no-interpolation-1 new-encoding (1+ index)
interpolation-rationale stream)))))
((eql ch #\n)
(let ((new-encoding (strcat (subseq encoding 0 index)
"s"
(subseq encoding (1+ index)))))
(cond ((eq (nth index interpolation-rationale) 'INTERNAL-SCALING)
(check-for-no-interpolation-1 new-encoding (1+ index)
interpolation-rationale stream))))))
(check-for-no-interpolation-1 encoding (1+ index)
interpolation-rationale stream)))))
;;************
;; is-argument -- see if string is in argument list
;;
;;************
(defun is-argument (arg arguments)
(dolist (a arguments)
(cond ((equal arg (cadr a)) (return t)))))
;; needs-mark-routine -- is there anything for GC to mark here?
;;
(defun needs-mark-routine (alg)
(or (get-slot alg 'sound-names)
(get-slot alg 'xlisp-pointers)))
;; lsc-needed-p -- see if we need the lsc variable declared
(defun lsc-needed-p (alg)
(let ((spec (get-slot alg 'logical-stop)))
(and spec (listp (car spec))
(eq (caar spec) 'MIN)
(cdar spec)
(cddar spec))))
;; write-initial-logical-stop-cnt -- writes part of snd_make_<name>
;;
(defun write-initial-logical-stop-cnt (alg stream)
(let ((spec (get-slot alg 'logical-stop))
min-list)
(cond ((and spec (listp (car spec))
(eq (caar spec) 'MIN)
(cdar spec))
(setf min-list (cdar spec))
; take stop_cnt from first argument in MIN list
(format stream
" susp->susp.log_stop_cnt = logical_stop_cnt_cvt(~A);\n"
(symbol-to-name (cadar spec)))
; modify stop_cnt to be minimum over all remaining arguments
(dolist (sym (cddar spec))
(let ((name (symbol-to-name sym)))
(format stream
" lsc = logical_stop_cnt_cvt(~A);\n" name)
(format stream
" if (susp->susp.log_stop_cnt > lsc)\n"
name)
(format stream
" susp->susp.log_stop_cnt = lsc;\n"
name))))
(t
(format stream
" susp->susp.log_stop_cnt = UNKNOWN;\n")))
))
;;************
;; write-mark
;;
;; Inputs:
;; alg - algorithm description
;; stream - stream on which to write .c file
;; Effect:
;; writes NAME_mark(...)
;;************
(defun write-mark (alg stream)
(let ((name (get-slot alg 'name))
(sound-names (get-slot alg 'sound-names))
(xlisp-pointers (get-slot alg 'xlisp-pointers)))
;----------------
; void NAME_mark(NAME_susp_type susp)
; {
; *WATCH*: printf("NAME_mark(%x)\n", susp);
;----------------
(format stream "~%~%void ~A_mark(~A_susp_type susp)~%{~%" name name)
(if *WATCH*
(format stream
" printf(\"~A_mark(%x)\\n\", susp);~%" name))
;----------------
; for each LVAL argument:
;
; if (susp->NAME) mark(susp->NAME);
;----------------
(dolist (name xlisp-pointers)
(format stream " if (susp->~A) mark(susp->~A);~%" name name))
;----------------
; for each sound argument:
;
; *WATCH*: printf("marking SND@%x in NAME@%x\n", susp->snd, susp);
; sound_xlmark(susp->NAME);
;----------------
(dolist (snd sound-names)
(if *watch*
(format stream
" printf(\"marking ~A@%x in ~A@%x\\n\", susp->~A, susp);~%"
snd name snd))
(format stream " sound_xlmark(susp->~A);~%" snd))
;----------------
; }
;----------------
(format stream "}~%")))
(print 'write-mark)
;;************
;; write-make
;;
;; Inputs:
;; alg - algorithm description
;; stream - stream on which to write .c file
;; Effect:
;; writes NAME_free(...), NAME_print_tree, and snd_make_NAME(...)
;;************
(defun write-make (alg stream)
(let ((name (get-slot alg 'name))
(sr (get-slot alg 'sample-rate))
(else-prefix "")
first-time
(sound-names (get-slot alg 'sound-names))
(logical-stop (car (get-slot alg 'logical-stop)))
(sound-to-name (get-slot alg 'sound-to-name))
(state-list (get-slot alg 'state))
(linear (get-slot alg 'linear))
(arguments (get-slot alg 'arguments))
(finalization (get-slot alg 'finalization))
(interpolation-list (get-slot alg 'interpolation-list))
(interpolation-rationale (get-slot alg 'interpolation-rationale))
encoding-list
(terminate (car (get-slot alg 'terminate)))
(type-check (car (get-slot alg 'type-check)))
(delay (get-slot alg 'delay))
(start (get-slot alg 'start)))
;--------------------
; void NAME_free(NAME_susp_type susp)
; {
;----------------
(format stream "~%~%void ~A_free(~A_susp_type susp)~%{~%"
name name)
;----------------
; if there's a finalization, do it
;----------------
(if finalization (print-strings finalization stream))
;----------------
; for each sound argument:
;
; sound_unref(susp->NAME);
;----------------
(dolist (name sound-names)
(format stream " sound_unref(susp->~A);~%" name))
;----------------
; ffree_generic(susp, sizeof(NAME_susp_node), "fn-name");
; }
;--------------------
(format stream
" ffree_generic(susp, sizeof(~A_susp_node), \"~A_free\");~%}~%"
name name)
;--------------------
; void NAME_print_tree(NAME_susp_type susp, int n)
; {
;----------------
(format stream "~%~%void ~A_print_tree(~A_susp_type susp, int n)~%{~%"
name name)
;----------------
; for each sound argument:
;
; indent(n);
; printf("NAME:");
; sound_print_tree_1(susp->NAME, n);
;----------------
(setf first-time t)
(dolist (name sound-names)
(cond (first-time
(setf first-time nil))
(t ; space between each iteration
(format stream "~%")))
(format stream " indent(n);~% stdputstr(\"~A:\");~%" name)
(format stream " sound_print_tree_1(susp->~A, n);~%" name))
;----------------
; }
;--------------------
(format stream "}~%")
;--------------------
; sound_type snd_make_NAME
;--------------------
(format stream "~%~%sound_type snd_make_~A" name)
;--------------------
; ( type name, ...)
;--------------------
(write-ansi-parameter-list stream "" arguments)
(format stream "~%")
(if (not *ANSI*)
(dolist (arg arguments)
(format stream " ~A ~A;~%" (car arg) (cadr arg))))
;--------------------
; NAME_susp_type susp;
;--------------------
(format stream
"{~% register ~A_susp_type susp;~%" name);
;; declare "state" variables with TEMP flag
;--------------------
; <type[i]> <name[i]>;
;--------------------
(dolist (state state-list)
(cond ((and (cdddr state)
(cadddr state)
(eq (cadddr state) 'TEMP))
(format stream " ~A ~A;~%"
(car state) (cadr state)))))
(write-sample-rate stream sr sound-names arguments)
; compute the t0 for new signal (default: use zero):
;
(write-start-time stream start arguments)
;--------------------
; int interp_desc = 0;
;--------------------
(cond (interpolation-list
(format stream " int interp_desc = 0;~%")))
;--------------------
; sample_type scale_factor = 1.0F;
; time_type t0_min; -- but only if there are sound args, implied by non-null sound-names
; long lsc;
;--------------------
(format stream " sample_type scale_factor = 1.0F;~%")
(if sound-names (format stream " time_type t0_min = t0;~%"))
(if (lsc-needed-p alg)
(format stream " long lsc;~%"))
; now do canonical ordering of commutable sounds
;
(dolist (lis (get-slot alg 'commutative))
;--------------------
; /* sort commuative signals: s1 s2 ... */
; snd_sort_<n>
; (...)
;--------------------
(format stream " /* sort commutative signals: ~A */~%" lis)
(format stream " snd_sort_~A" (length lis))
(write-parameter-list stream ""
(append (mapcar
'(lambda (snd)
(strcat "&" (cdr (assoc snd sound-to-name))))
lis)
'("sr")))
(format stream ";~%~%"))
; figure scale factor -- if signal is linear wrt some interpolated or
; ramped signal (which do the multiply anyway), then put the scale
; factor there.
;--------------------
; /* combine scale factors of linear inputs <linear> */
;--------------------
(cond (linear
(format stream
" /* combine scale factors of linear inputs ~A */~%" linear)))
;--------------------
; scale_factor *= NAME ->scale;
; NAME ->scale = 1.0F;
;--------------------
(dolist (snd linear)
(let ((name (cdr (assoc snd sound-to-name))))
(format stream " scale_factor *= ~A->scale;~%" name)
(format stream " ~A->scale = 1.0F;~%" name)))
;--------------------
; /* try to push scale_factor back to a low sr input */
;--------------------
(cond (linear
(format stream
"~% /* try to push scale_factor back to a low sr input */~%")))
;--------------------
; if (NAME ->sr < sr) {
; NAME ->scale = scale_factor; scale_factor = 1.0F; }
;--------------------
(dolist (snd linear)
(let ((name (cdr (assoc snd sound-to-name))))
(format stream
" ~Aif (~A->sr < sr) { ~A->scale = scale_factor; scale_factor = 1.0F; }~%"
else-prefix name name)
(setf else-prefix "else ")))
(if linear (format stream "~%"))
;-------------------
; insert TYPE-CHECK code here
;-------------------
(display "write-make" type-check)
(if type-check
(format stream type-check))
;--------------------
; falloc_generic(susp, NAME_susp_node, "fn-name");
;--------------------
(format stream
" falloc_generic(susp, ~A_susp_node, \"snd_make_~A\");~%" name name)
;; initialize state: the state list has (type field initialization [temp])
;--------------------
; susp-> <state[i]> = <value[i]>
;--------------------
;; if TEMP is present, generate:
;--------------------
; <state[i]> = <value[i]>
;--------------------
(dolist (state state-list)
(let ((prefix "susp->"))
(cond ((and (cdddr state)
(cadddr state)
(eq (cadddr state) 'TEMP))
(setf prefix "")))
(format stream " ~A~A = ~A;~%"
prefix (cadr state) (caddr state))))
; if we have a choice of implementations, select one
(cond ((< 1 (length interpolation-list))
;--------------------
; /* select a susp fn based on sample rates */
;--------------------
; build a descriptor
(format stream
"~% /* select a susp fn based on sample rates */~%")
;------------------------
; interp_desc = (interp_desc << 2) + interp_style( NAME, sr);
;------------------------
(dolist (snd sound-names)
(format stream
" interp_desc = (interp_desc << 2) + interp_style(~A, sr);~%"
snd))
;--------------------
; switch (interp_desc) {
;--------------------
(cond (interpolation-list
(format stream " switch (interp_desc) {~%")))
;--------------------------
; case INTERP_<encoding>: susp->susp.fetch =
; NAME_<encoding>_fetch; break;
;--------------------------
(setf encoding-list (mapcar #'encode interpolation-list))
(dolist (encoding encoding-list)
(check-for-no-interpolation encoding interpolation-rationale stream)
(format stream "susp->susp.fetch = ~A_~A_fetch; break;~%"
name encoding))
;--------------------------
; default: snd_badsr(); break;
;--------------------------
(format stream " default: snd_badsr(); break;~%")
;--------------------
; } /* initialize susp state */
;-------------------------
(format stream " }~%~%"))
(interpolation-list
(format stream " susp->susp.fetch = ~A_~A_fetch;~%"
name (encode (car interpolation-list))))
(t
;-------------------------
; susp->susp.fetch = NAME__fetch;
;-------------------------
(format stream " susp->susp.fetch = ~A__fetch;~%~%" name)))
;----------------
; /* compute terminate count */
;----------------
(cond ((terminate-check-needed terminate alg)
(cond ((eq (car terminate) 'AT)
(let ((time-expr (cadr terminate)))
;----------------
; susp->terminate_cnt = round(((TIME-EXPR) - t0) * sr);
;----------------
(format stream
" susp->terminate_cnt = round(((~A) - t0) * sr);~%"
time-expr)))
((eq (car terminate) 'AFTER)
(let ((dur-expr (cadr terminate)))
;----------------
; susp->terminate_cnt = round((DUR-EXPR) * sr);
;----------------
(format stream
" susp->terminate_cnt = round((~A) * sr);~%"
dur-expr)))
(t
;----------------
; susp->terminate_cnt = UNKNOWN;
;----------------
(format stream " susp->terminate_cnt = UNKNOWN;~%")))))
;----------------
; /* handle unequal start times, if any */
;----------------
(if sound-names
(format stream " /* handle unequal start times, if any */~%"))
;----------------
; for each sound argument:
; if (t0 < NAME->t0) sound_prepend_zeros(NAME, t0);
;----------------
(dolist (name sound-names)
(format stream
" if (t0 < ~A->t0) sound_prepend_zeros(~A, t0);~%" name name))
;----------------
; t0_min = min(NAME1->t0, min(NAME2->t0, ... NAMEn->t0, t0)...);
;----------------
(cond (sound-names
(format stream " /* minimum start time over all inputs: */~%")
(format stream " t0_min = ")
(dolist (name sound-names)
(format stream "min(~A->t0, " name))
(format stream "t0")
(dolist (name sound-names)
(format stream ")"))
(format stream ";~%")))
;----------------
; /* how many samples to toss before t0: */
; susp->susp.toss_cnt = (long) ((t0 - t0_min) * sr + <DELAY>.5);
; if (susp->susp.toss_cnt > 0) {
; susp->susp.keep_fetch = susp->susp.fetch;
; susp->susp.fetch = NAME_toss_fetch;
; t0 = t0_min; -- DELETED 3MAY99 by RBD
; }
;----------------
(cond (sound-names
(format stream " /* how many samples to toss before t0: */\n")
(if delay
(format stream " /* Toss an extra ~A samples to make up for internal buffering: */\n" delay))
(format stream " susp->susp.toss_cnt = (long) ((t0 - t0_min) * sr + ~A.5);\n"
(if delay delay 0))
(format stream " if (susp->susp.toss_cnt > 0) {\n")
(format stream "\tsusp->susp.keep_fetch = susp->susp.fetch;\n")
(format stream "\tsusp->susp.fetch = ~A_toss_fetch;~%" name)
; (format stream "\tt0 = t0_min;~% }\n\n")))
(format stream " }\n\n")))
;--------------------
; /* initialize susp state */
; susp->susp.free = NAME_free;
; susp->susp.sr = sr;
; susp->susp.t0 = t0;
;--------------------
(format stream " /* initialize susp state */~%")
(format stream " susp->susp.free = ~A_free;~%" name)
(format stream " susp->susp.sr = sr;~%")
(format stream " susp->susp.t0 = t0;~%")
;----------------
; if there are sound arguments:
; susp->susp.mark = NAME_mark;
; otherwise...
; susp->susp.mark = NULL;
;----------------
(let ((value "NULL"))
(cond ((needs-mark-routine alg)
(setf value (strcat name "_mark"))))
(format stream " susp->susp.mark = ~A;~%" value))
;----------------
; for debugging...
; susp->susp.print_tree = NAME_print_tree;
; susp->susp.name = "NAME";
;----------------
(format stream " susp->susp.print_tree = ~A_print_tree;~%" name)
(format stream " susp->susp.name = \"~A\";~%" name)
;----------------
; if there is a logical stop attribute:
; susp->logically_stopped = false;
; susp->susp.log_stop_cnt = UNKNOWN;
;----------------
(cond ((logical-stop-check-needed logical-stop)
(format stream
" susp->logically_stopped = false;\n")))
(write-initial-logical-stop-cnt alg stream)
;--------------------
; ramped or interpolated:
;
; susp->started = false;
;--------------------
(cond ((any-ramp-or-interp-in interpolation-list)
(format stream " susp->started = false;~%")))
;--------------------
; susp->susp.current = 0;
;--------------------
(format stream " susp->susp.current = 0;~%")
;----------------------------
; For each sound arg:
;
; susp-> <arg> = <arg>;
; susp-> <arg>_cnt = 0;
;----------------------------
(dotimes (n (length (get alg 'sound-args)))
(let ((interpolation (union-of-nth interpolation-list n)))
(setf arg (nth n sound-names)) ; get name of signal
(format stream " susp->~A = ~A;~%" arg arg)
(format stream " susp->~A_cnt = 0;~%" arg)
;-----------------------------------------------
; Interpolation:
;
; susp-> <arg>_pHaSe = 0.0;
; susp-> <arg>_pHaSe_iNcR = <arg> ->sr
;-----------------------------------------------
(cond ((member 'INTERP interpolation)
(format stream " susp->~A_pHaSe = 0.0;~%" arg)
(format stream " susp->~A_pHaSe_iNcR = ~A->sr / sr;~%"
arg arg)))
;-----------------------------------------------
; Ramp:
;
; susp->output_per_<arg> = <arg> ->sr;
;-----------------------------------------------
(cond ((member 'RAMP interpolation)
(format stream " susp->~A_n = 0;~%" arg)
(format stream " susp->output_per_~A = sr / ~A->sr;~%"
arg arg)))))
;----------------------------
; return sound_create (snd_susp_type)susp, t0, sr, scale_factor);
;----------------------------
(format stream
" return sound_create((snd_susp_type)susp, t0, sr, scale_factor);~%}~%")))
(print 'write-make)
;;************
;; write-parameter-list -- with comma separator, open and close parens
;;
;;************
(defun write-parameter-list (stream prefix strings)
(let ((comma ""))
(format stream "(")
(dolist (parm strings)
(format stream "~A~A~A" comma prefix parm)
(setf comma ", "))
(format stream ")")))
;;************
;; write-ansi-prototype-list -- with comma separator, open and close parens
;;
;; Inputs:
;; stream - output stream
;; prefix - arg prefix, perhaps ""
;; args - argument type/name pairs of the form
;; ( (type1 name1) (type2 name2) ... )
;; Effect:
;; if *ANSI* is set T, writes ANSI-style parameter list of the form
;; type name, ...
;; if *ANSI* is set NIL, writes antique-style parameter list of the form
;; ()
;;************
(defun write-ansi-prototype-list (stream prefix args)
(let ((comma ""))
(format stream "(")
(if *ANSI*
(dolist (parm args)
;--------------------
; for each parameter
; <comma>type <prefix><parm>
;--------------------
(format stream "~A~A ~A~A" comma (car parm) prefix (cadr parm))
(setf comma ", "))
)
(format stream ")")))
;;************
;; write-ansi-parameter-list
;;
;; Inputs:
;; stream - output stream
;; prefix - arg prefix, perhaps ""
;; args - argument type/name pairs of the form
;; ( (type1 name1) (type2 name2) ... )
;; Effect:
;; if *ANSI* is set T, writes ANSI-style parameter list of the form
;; (type name, ...)
;; if *ANSI* is set NIL, writes antique-style parameter list of the form
;; (name, ...)
;; Note:
;; to get a space between types and arguments, a space is prepended to prefix if
;; this is an *ANSI* arg list.
;;************
(defun write-ansi-parameter-list (stream prefix args)
(let ((comma ""))
(format stream "(")
(cond (*ANSI*
(setf prefix (strcat " " prefix))))
(dolist (parm args)
(format stream "~A~A~A~A" comma
(if *ANSI* (car parm) "")
prefix (cadr parm))
(setf comma ", ")
)
(format stream ")")))
;;************
;; write-sample-rate
;; Effect:
;; declare sr and compute the sample rate for the new signal
;; Notes:
;; If sr is an input parameter, it is not declared
;; If (SAMPLE-RATE expr) is specified, declare sr to be initialized
;; to the expr
;; If (SAMPLE-RATE (MAX s1 s2 ...)), sr is initialized to the max.
;; Otherwise, sr is initialized to the max of the sample rates of
;; all the sound-type arguments
;;************
(defun write-sample-rate (stream sr sound-names arguments)
;; if sr is "sr" and "sr" is a parameter, then do nothing:
(display "write-sample-rate: " sr sound-names arguments)
(cond ( (and (equal sr "sr") (is-argument "sr" arguments))
;---------------------
; /* sr specified as input parameter */
;---------------------
(format stream " /* sr specified as input parameter */~%")
)
;; else if sample rate is specified, use it to initialize sr:
((stringp sr)
(display "write-sample-rate: using specified sr" sr)
;---------------------
; rate_type sr = <sr>;
;---------------------
(format stream " rate_type sr = ~A;~%" sr)
)
;; else look for (MAX ...) expression
((and (listp sr) (eq (car sr) 'MAX))
(format stream " rate_type sr = ")
(write-redux-of-names stream "max"
(mapcar #'symbol-to-name (cdr sr)) "->sr")
(format stream ";~%")
)
;; else assume sr is max of sr's of all sound arguments
(sound-names
;---------------------
; rate_type sr = max( <arg[0]> ->sr, <arg[i]> ->sr);
;---------------------
(format stream " rate_type sr = ") ; jmn
(write-redux-of-names stream "max" sound-names "->sr")
(format stream ";~%")
)
(t
(error "Missing SAMPLE-RATE specification."))
)
)
(defun write-redux-of-names (stream fn sound-names suffix)
(dotimes (n (1- (length sound-names)))
(format stream "~A(" fn))
(format stream "~A~A" (car sound-names) suffix)
(dolist (snd (cdr sound-names))
(format stream ", ~A~A)" snd suffix)))
;;************
;; write-start-time
;; Effect:
;; declare sr and compute the start time for the new signal
;; Notes:
;; If t0 is an input parameter, it is not declared
;; If (START (AT expr)) is specified, declare t0 to be initialized
;; to the expr
;; Otherwise, t0 is initialized to 0
;;************
(defun write-start-time (stream start arguments)
;; if t0 is "t0" and "t0" is a parameter, then do nothing:
(display "write-start time:" start arguments)
(cond ((is-argument "t0" arguments)
;---------------------
; /* t0 specified as input parameter */
;---------------------
(format stream " /* t0 specified as input parameter */~%"))
;; else if start time is specified, use it to initialize sr:
(t (cond (start
;---------------
; (START (AT <expr>)) specified:
;
; time_type t0 = <expr>;
;---------------
(setf start (car start))
(cond ((eq (car start) 'AT)
(format stream " time_type t0 = ~A;~%" (cadr start)))
((eq (car start) 'MIN)
(format stream " time_type t0 = ")
(write-redux-of-names stream "min"
(c-names (cdr start)) "->t0")
(format stream ";~%"))
((eq (car start) 'MAX)
(format stream " time_type t0 = ")
(write-redux-of-names stream "max"
(c-names (cdr start)) "->t0")
(format stream ";~%"))
(t (error (format nil
"Unrecognized START specification ~A" start)))))
;---------------
; time_type t0 = 0.0;
;---------------
(t (format stream " time_type t0 = 0.0;~%"))))))
;; c-names -- get the C names corresponding to list of symbols
;;
(defun c-names (syms) (mapcar '(lambda (sym) (string-downcase (symbol-name sym))) syms))
(defun is-table (alg snd)
(dolist (table (get-slot alg 'table))
(cond ((equal snd table)
(display "is-table" snd table)
(return t)))))
;; write-xlmake -- write out a function snd_NAME to be called by xlisp
;
; this function copies any sound arguments and passes them on to snd_make_NAME
;
(defun write-xlmake (alg stream)
(let ((name (get-slot alg 'name))
(sound-names (get-slot alg 'sound-names))
(arguments (get-slot alg 'arguments))
comma)
;--------------------
; sound_type snd_NAME
;--------------------
(format stream "~%~%sound_type snd_~A" name)
;--------------------
; ( type name, ...)
; {
;--------------------
(write-ansi-parameter-list stream "" arguments)
(format stream "~%")
(if (not *ANSI*)
(dolist (arg arguments)
(format stream " ~A ~A;~%" (car arg) (cadr arg))))
(format stream "{~%")
;----------------
; for each sound argument that is not a table
; sound_type SND_copy = sound_copy(SND);
;----------------
(dolist (arg arguments)
(cond ((equal (car arg) "sound_type")
(let ((snd (cadr arg)))
(cond ((not (is-table alg snd))
(format stream
" sound_type ~A_copy = sound_copy(~A);~%"
snd snd)))))))
;----------------
; now call snd_make_ALG. When SND is a sound_type that is not a table,
; substitute SND_copy for SND.
;----------------
(format stream " return snd_make_~A(" name)
(setf comma "")
(dolist (arg arguments)
(let ((suffix ""))
(cond ((and (equal (car arg) "sound_type")
(not (is-table alg (cadr arg))))
(setf suffix "_copy")))
(format stream "~A~A~A" comma (cadr arg) suffix)
(setf comma ", ")))
(format stream ");~%}~%")))
Reference in New Issue View Git Blame Copy Permalink