writesusp.lsp

Audacity是一款用於錄音和編輯聲音的、免費的開放源碼軟體。它可以執行於Mac OS X、Microsoft Windows、GNU/Linux和其它作業系統

;;************
;;          Change Log
;; Date     | Change
;;----------+---------------------
;; 17-Dec-91 | [1.1] <jmn> Created
;; 17-Dec-91 | [1.1] <jmn> cast arg of snd_list_create to correct type
;; 17-Dec-91 | [1.1] <jmn> cast truncation as (int) explicitly, avoid lint
;;           | errors
;; 13-Jan-92 | [1.2] <jmn> reformatted and recommented
;;************

;;****************
;; depended-on-in-inner-loop - test if variables updated in inner loop
;;****************
(defun depended-on-in-inner-loop (vars interp sound-names step-function)
  (dotimes (n (length interp))
    (let ((method (nth n interp))
          (name (nth n sound-names))
          interpolate-samples)
      (setf interpolate-samples
            (not (member (name-to-symbol name) step-function)))
      (cond ((and (or (member method '(NONE SCALE INTERP))
                      interpolate-samples)
                  (member name vars :test #'equal))
             (return t))))))

;;****************
;; fixup-depends-prime - write code to update depend variables
;; 	this code is only run the first time the suspension
;;	is invoked
;;****************
(defun fixup-depends-prime (alg stream name indent var-name)
  (let ((depends (get-slot alg 'depends)))
    (dolist (dep depends)
      (cond ((equal name (cadr dep))
             (cond ((eq (cadddr dep) 'TEMP)
                    (format stream "~A~A = ~A;~%" indent (car dep)
                        (fixup-substitutions-prime alg
                                (caddr dep) name var-name)))
                   (t
                    (format stream "~Asusp->~A = ~A;~%" indent (car dep)
                        (fixup-substitutions-prime alg
                                (caddr dep) name var-name)))))))))

(print 'fixup-depends-prime)


;;****************
;; fixup-depends-prime-decls - write declarations for temp depend variables
;; 	this code is only run the first time the suspension
;;	is invoked
;;****************
(defun fixup-depends-prime-decls (alg stream name)
  (let ((depends (get-slot alg 'depends)))
    (dolist (dep depends)
      (cond ((equal name (cadr dep))
             (cond ((eq (cadddr dep) 'TEMP)
                    (format stream "\t    ~A ~A;~%" (car (cddddr dep))
                                   (car dep)))))))))

(print 'fixup-depends-prime-decls)


;;****************
;; fixup-substitutions-prime - substitute susp-><var> for <var> for each 
;;	state variable in code, also substitute var-name for name
;;	(this is the depended-on value)
;;****************
(defun fixup-substitutions-prime (alg code name var-name)
  (dolist (state (get-slot alg 'state))
    (let ((var (cadr state)))
      (setf code (substitute code var (strcat "susp->" var) t))))
  (if name (setf code (substitute code name var-name nil)))
  code)

(print 'fixup-substitutions-prime)


;;****************
;; fixup-depends - write code to declare and update depend variables
;; 	this is called at declaration time (the point where 
;;	declarations should be output), but also generates code
;; 	to be output after the depended-on variable is updated
;;****************
(defun fixup-depends (alg stream name)
  (format stream "/* fixup-depends ~A */~%" name)
  (let ((depends (get-slot alg 'depends))
        (fixup-code "")
        (var-name (strcat name "_x1_sample_reg")))
    (dolist (dep depends)
      (cond ((equal name (cadr dep))
             (cond ((eq (cadddr dep) 'TEMP)
                    (format stream "\t\t~A ~A; ~%" (car (cddddr dep))
                                (car dep))
                    (setf fixup-code
                          (format nil "~A\t\t~A = ~A;~%"
                                  fixup-code (car dep) 
                                  (fixup-substitutions alg
                                   (caddr dep) name var-name))))
                   (t
                    (setf fixup-code
                          (format nil "~A\t\t~A_reg = susp->~A = ~A;~%"
                                  fixup-code (car dep) (car dep)
                                  (fixup-substitutions alg
                                   (caddr dep) name var-name))))))))
    (put-slot alg fixup-code 'fixup-code)))

(print 'fixup-depends)


;;****************
;; fixup-substitutions - substitute <var>_reg for <var> for each 
;;	state variable in code, also substitute var-name for name
;;	(this is the depended-on value)
;;****************
(defun fixup-substitutions (alg code name var-name)
  (dolist (state (get-slot alg 'state))
    (let ((var (cadr state)))
      (setf code (substitute code var (strcat var "_reg") t))))
  (substitute code name var-name nil))

(print 'fixup-substitutions)


;;****************
;; in-min-list - see if name is in TERMINATE MIN list or
;;   LOGICAL-STOP MIN list
;;
;; returns true if algorithm specified, say (TERMINATE (MIN s1 s2 s3)) and
;; name is, say, "s2".
;; NOTE: name is a string, so we have to do a lookup to get the symbol name
;;****************
(defun in-min-list (name alg terminate-or-logical-stop)
  (let ((spec (get alg terminate-or-logical-stop)))
;    (display "in-min-list" name alg terminate-or-logical-stop spec)
    (and spec
         (listp (car spec))
         (eq (caar spec) 'MIN)
         (member (name-to-symbol name) (cdar spec)))))


;;****************
;; logical-stop-check-needed -- says if we need to check for logical stop
;;    after the outer loop
;; the argument is the logical-stop clause from the algorithm prop list
;;****************
(defun logical-stop-check-needed (logical-stop)
  (cond ((and logical-stop
              (listp logical-stop)
              (or (eq (car logical-stop) 'MIN)
                  (eq (car logical-stop) 'AT))))))


;;****************
;; susp-check-fn -- find fn to check need for new block of samples
;;
;; To simply check if susp->S_ptr points to something, you call 
;; susp_check_samples(S, S_ptr, S_cnt), but during this check, it is
;; also necessary to check for termination condition and logical stop
;; condition, BUT ONLY if S is in a MIN list for the TERMINATE or
;; LOGICAL-STOP attributes (i.e. this signal stops when S does).
;;
;; The algorithm is: if S is on the LOGICAL-STOP MIN list and on
;; the TERMINATE MIN list, then call susp_check_term_log_samples.
;;Otherwise if S is on the LOGICAL-STOP MIN list then call
;; susp_check_log_samples.  Otherwise, if S is on the TERMINATE MIN
;; list, call susp_check_term_samples.  The "normal" case should be 
;; susp_check_term_samples, which happens when the LOGICAL-STOP
;; MIN list is empty (nothing was specified).  Note that a signal logically
;; stops at termination time anyway, so this achieves the logically stopped
;; condition with no checking.
;;****************
(defun susp-check-fn (name alg)
  (let ((in-log-list (in-min-list name alg 'logical-stop))
        (in-term-list (in-min-list name alg 'terminate)))
    (cond ((and in-log-list in-term-list)
           "susp_check_term_log_samples")
          (in-log-list
           "susp_check_log_samples")
          (in-term-list
           "susp_check_term_samples")
          (t
           "susp_check_samples"))))


;;************
;; write-depend-decls -- declare TEMP depends variables
;;
;;************
;(defun write-depend-decls (alg stream)
;  (dolist (dep (get-slot alg 'depends))
;    (cond ((eq (cadddr dep) 'TEMP)
;	   (format stream "\t~A ~A; ~%" (car (cddddr dep)) (car dep))))))
;--------

(defun write-depend-decls (alg stream interp sound-names step-function)
  (dotimes (n (length interp))
    (let ((name (nth n sound-names))
          (method (nth n interp))
          is-step)
      (cond ((eq method 'INTERP)
             (setf is-step (member (name-to-symbol name) step-function))
             (cond (is-step
                    (fixup-depends-prime-decls alg stream name))))))))


;;************
;; write-prime -- write conditional code to prime input sounds and susp
;;
;;************
(defun write-prime (alg stream interp sound-names)
 (let ((step-function (get-slot alg 'step-function)))
  ;------------------------------
  ;   /* make sure sounds are primed with first values */
  ;------------------------------
  (format stream "~%    /* make sure sounds are primed with first values */~%")

  ;------------------------------
  ;   if  (!susp->started) {
  ;       susp->started = true;
  ;------------------------------

  (format stream "    if (!susp->started) {~%")
  ; this is generating extraneous declarations, is it necessary?
  ; yes, at least sometimes, so we're leaving it in
  ; "atonev.alg" is a good test case to prove you can't comment this out
  (write-depend-decls alg stream interp sound-names step-function)
  (format stream "\tsusp->started = true;~%")

  ;------------------------------
  ; for each method
  ;------------------------------
  (dotimes (n (length interp))
    (let ((name (nth n sound-names))
          (method (nth n interp))
          is-step)
      (cond ((eq method 'INTERP)
             ;--------------------
             ; susp_XX_samples(NAME, NAME_ptr, NAME_cnt);
             ; susp->NAME_x1_sample = susp_fetch_sample(NAME, NAME_ptr,
             ;                                          NAME_cnt);
             ; <fixup depends variables> (if a step function)
             ;--------------------
             (format stream "\t~A(~A, ~A_ptr, ~A_cnt);~%"
              (susp-check-fn name alg) name name name)
             (format stream 
              "\tsusp->~A_x1_sample = susp_fetch_sample(~A, ~A_ptr, ~A_cnt);~%"
              name name name name)
             (setf is-step (member (name-to-symbol name) step-function))
             (cond (is-step
                    (fixup-depends-prime alg stream name "\t"
                        (strcat "susp->" name "_x1_sample")))))
            ((eq method 'RAMP)
             ;--------------------
             ; susp->NAME_pHaSe = 1.0;
             ;--------------------
             (format stream "\tsusp->~A_pHaSe = ~A;~%" name "1.0")))))

  ;--------------------
  ; *WATCH*
  ;       show_samples(2,susp->NAME_x2,0);
  ;--------------------
; (if *WATCH*
;   (format stream "\tshow_samples(2,~A_x2,0);~%" name))

  ;--------------------
  ; }
  ;--------------------
  (format stream "    }~%")))
      

(print 'write-prime)

;;************
;; show-samples-option
;;
;; Inputs:
;;	stream: output stream for file
;;	name: token to use for forming name
;; Effect:
;;	Writes sampling clause
;;************
(defun show-samples-option (stream name)
    ;----------------------------
    ;	else
    ;	   { /* just show NAME */
    ;	    show_samples(1,NAME,NAME_ptr - NAME->samples); 
    ;	   } /* just show NAME */
    ;----------------------------
;  (format stream "\t    show_samples(1, ~A, 0);~%\t} else {~%" name)
;  (format stream "\t    show_samples(1, ~A, ~A_ptr - ~A->samples);~%~%"
;          name name name)
)


(print "show-samples-option")

;;************
;; write-susp -- compile the suspension according to interpolation spec
;;
;;************

(defun write-susp (alg stream)
  (let* ((interp (get alg 'interpolation))
         (encoding (encode interp))
         (sound-names (get alg 'sound-names))
         (name (get-slot alg 'name))
         (logical-stop (car (get-slot alg 'logical-stop)))
         (terminate (car (get-slot alg 'terminate)))
         (outer-loop (get-slot alg 'outer-loop))
         (step-function (get-slot alg 'step-function))
         (depends (get-slot alg 'depends))
         (inner-loop (get-slot alg 'inner-loop))
         n s m p fn-name loop-prefix joint-depend)

    (display "write-susp" interp encoding)

    ;---------------------------
    ; non-ANSI:
    ;     void NAME_<encoding>_fetch(susp, snd_list)
    ;   register pwl_susp_type susp;
    ;        snd_list_type snd_list;
    ;	     {
    ; ANSI:
    ;     void NAME_<encoding>_fetch(register susp_type susp, snd_list_type snd_list)
    ;        {
    ;---------------------------