writemake.lsp

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

;;************
;; 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