writemake.lsp

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

             (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))

           ;--------------------
           ;        } /* 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)