translate.lsp

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

      (putprop name (cdr slot) (car slot)))
    name))

;;****************
;; name-to-symbol -- convert from case-sensitive C name to internal symbol
;;****************
(defun name-to-symbol (name) (intern (string-upcase name)))



;;**********
;; position -- find a pattern in a string
;;
;; Inputs:
;;	s -
;;	p -
;;**********

(defun position (s p)
  (let (result (len (length p)))
    (dotimes (n (+ 1 (length s) (- len)))
      (cond ((equal (subseq s n (+ n len)) p)
         (setf result n)
         (return))))
    result))


;;**********
;; print a list of strings to a stream
;;
;; Inputs:
;;	strings - a list of strings
;;	stream - stream on which to write the strings
;; Effect:
;;	
;;**********

(defun print-strings (strings stream)
  (dolist (s strings) (princ s stream)))



;;**********
;; put-slot: 
;;	
;; Inputs:
;;	schema - name of the schema
;;	value - value of the attribute to be added or modified
;;	property - name of the attribute to be modified
;;
;;**********

(setfn put-slot putprop)


(defun return-nil (ignore) nil)

;;**********
;; scale-check -- make sure scale method is not used on linear input or
;;	on input where scaling is factored into other computation; 
;; 	Also, don't use NONE scale method if sound appears on always-scale
;; 	list (these sounds have low likelihood of ever using 'NONE method -
;;	see fmosc for an example).  Note that if you say always-scale (removing
;;                NONE) and linear or internal-scaling (removing SCALE), then you'll
;;                be in big trouble.
;;
;; Inputs:
;;	alg - algorithm description
;;	spec -
;; Notes:
;;	
;;**********

(defun scale-check (alg spec)
  (let ((sounds (get-slot alg 'sound-args))
    (linear (get-slot alg 'linear))
    (internal-scaling (get-slot alg 'internal-scaling))
    (always-scale (get-slot alg 'always-scale))
    snd 
    (result t)
       )
    ; initially, the rationale list is nil for each sound:
    (cond (always-scale
       (dotimes (n (length spec))  ; look at each method in spec
         (cond ((eq 'NONE (nth n spec))
            (setf snd (nth n sounds))
            (cond ((member snd always-scale)
               (setf result nil)
               (return))))))))
    (cond ((member 'SCALE spec)	; quick test
       (dotimes (n (length spec))  ; look at each method in spec
         (cond ((eq 'SCALE (nth n spec))
            (setf snd (nth n sounds))
            (cond ((or (member snd linear) 
                   (member snd internal-scaling))
               (if (member snd internal-scaling) 
                 (format t "WARNING internal scaling not fully debugged, check your results...\n"))
               (setf result nil)
               (return))))))))
    result))


;;****************
;; space-if-no-trailing-star -- returns "" if arg ends with "*", else space
;;****************
(defun space-if-no-trailing-star (str)
  (if (equal #\* (char str (1- (length str))))
    ""
    #\Space))


;; SPEC-IS-NONE-OR-SCALE -- see if spec is none or scale, called by sr-check
;;
;; sig is the search key
;; sound-args is a list, one element matches sig
;; spec is list of specs corresponding to elements in sound-args
;; return t if (eq sig (nth n sound-args)) and (nth n spec) is 
;; either 'none or 'scale
;;
(defun spec-is-none-or-scale (sig sound-args spec)                      
  (dolist (arg sound-args)
      (cond ((eq sig arg)
         (return (member (car spec) '(NONE SCALE)))))
      (setf spec (cdr spec))))


;;****************
;; sr-check -- see if interpolation spec is ok wrt sample rate spec
;;****************
(defun sr-check (alg spec)
  (let ((sample-rate (get-slot alg 'sample-rate))
    (sound-args (get-slot alg 'sound-args))
    (result t))
    ;; if expression given, then anything is ok
    (cond ((stringp sample-rate) t)
      ;; if (MAX ...) expression given, then one of signals must be NONE or SCALE
      ((and (listp sample-rate) (eq (car sample-rate) 'MAX))
       (dolist (sig (cdr sample-rate))  ; for all sig in max list ...
           (cond ((not (spec-is-none-or-scale sig sound-args spec))
              (setf result nil))))
       result)
      ;; if no expression given, then one signal must be NONE or SCALE
      ((or (member 'NONE spec) (member 'SCALE spec)) t)
      ;; o.w. return false
      (t nil))))


;;****************
;; symbol-to-name -- convert from internal symbol to case-sensitive C name
;;****************
(defun symbol-to-name (symbol) (get symbol 'string-name))



;;**********
;; translate -- main procedure
;;
;; Inputs:
;;	name - string which is name of file to translate
;; Effect:
;;	Reads the algorithm specification as "name.alg"
;;	Generates output files "name.c" and "name.h"
;;**********
(defun translate (name)
  (prog* ((infile (concatenate 'string name ".alg"))
      (outfile (concatenate 'string name ".c"))
      (hfile (concatenate 'string name ".h"))
      (inf (open infile :direction :input))
      (hf (open hfile :direction :output))
      (outf (open outfile :direction :output)))

   (if (null inf) (error "translate: couldn't open inf"))
   (if (null hf) (error "translate: couldn't open hf"))
   (if (null outf) (error "translate: couldn't open outf"))

   (display "FILES" inf hf outf)

   (if *WATCH*
      (print "**** TRACING HOOKS ENABLED!  ****")
      (print "**** NO TRACING ****")
   )
   loop
    ;; read the algorithm description 
    (setq alg (read inf))

    ;; if the algorithm is NIL, we had some sort of failure
    (cond ((null alg) 
       (close inf)
       (close hf)
       (close outf)
       (return)))

    ;; we have read in the high-level schema specification
    ;; convert it to a schema
    (display "translate: " infile alg)
    (setf alg (make-schema-from-slots alg))
    (display "translate: schema " alg)

    ;; save the .h file name
    (put-slot alg hfile 'hfile)
    ;; perform the type-check on the schema parameters
    (type-check-and-transform alg)
    (display "translate: transformed schema" alg)
    (code-gen alg outf hf)
    (display "translate: finished code-gen")
    (setf save-alg alg)
    (go loop)
 )
)
    

(print 'translate)

;;**********
;; type-check-and-transform -- fix up slots in an algorithm schema
;;
;; Inputs:
;;	alg - the name of the algorithm; values are its property list
;; Notes:
;;	Report an error if required slot values are absent
;;	Any slot which should be a single value and is a list is
;;	coerced to be the car of the list
;;	Put argument string names on argument symbols for conversion.
;;**********

(defun type-check-and-transform (alg)

  ;; the quoted list that follows 'slot' is the list of required
  ;; parameters.  If any parameter is missing, this will cause an
  ;; error

  (dolist (slot '(name inner-loop)) ; other necessarily non-nil slots go here
    (cond ((null (get-slot alg slot))
       (error "missing slot"))))

  ; fix single-value slots to not be stored as lists:
  ;     If the value is a list, the value is coerced to
  ;	be the car of the list

  (dolist 
       (slot 
     '(name inner-loop sample-rate support-functions inline-interpolation delay
       )) 
       (put-slot alg (car (get-slot alg slot)) slot))

  ; Make sure there are no strings, only symbols, in TERMINATE and
  ; LOGICAL-STOP MIN lists: (TERMINATE (MIN "s1")) is wrong, it should be
  ; (TERMINATE (MIN s1))

  (dolist (field '(terminate logical-stop))
    (setf spec (get-slot alg field))
    (display "type-check" spec field)
    (cond ((and spec
        (listp (car spec))
        (member (caar spec) '(MIN MAX)))
       (dolist (entry (cdar spec))
         (display "type-check" spec field entry)
         (cond ((eq (type-of entry) 'STRING)
            (error "MIN and MAX args are symbols, not strings"
               spec)))))))

  ; (ARGUMENTS ( "type1" "name1") ("type2" "name2") ... ("typen" "namen") )
  ; if "sr" is the name of an argument, its type must be "rate_type"
  ; i.e. ("rate_type" "sr")

  (dolist (arg (get-slot alg 'arguments))
    (cond ((and (equal (cadr arg) "sr")
           (not (equal (car arg) "rate_type")))
       (error "argument sr must be of type rate_type"))
      ((equal (car arg) "sound_type")
       (putprop (name-to-symbol (cadr arg)) (cadr arg) 'string-name)))))



;;**********
;; union-of-nth -- get the union of the nth element of each sublist
;;
;;**********
(defun union-of-nth (lis n)
  (let (result a)
    (dolist (sublis lis)
      (setf a (nth n sublis))
      (cond ((not (member a result)) 
         (setf result (cons a result)))))
    result))


(print 'union-of-nth)

;;**********
;; write-header -- write a header file for the suspension create routine
;;
;; Inputs:
;;	alg - algorithm name
;;	stream - output stream for .h file
;; Effect:
;;	Writes to the stream
;;		sound_type snd_make_NAME();
;; Notes:
;;	Uses NAME property of algorithm to emit the procedure header to
;;	the .h file
;;**********

(setf c-to-xlisp-type '(
  ("double" . "ANYNUM")
  ("float" . "ANYNUM")
  ("time_type" . "ANYNUM")
  ("rate_type" . "ANYNUM")
  ("sample_type" . "ANYNUM")
  ("sound_type" . "SOUND")
  ("char *" . "STRING")
  ("LVAL" . "ANY")
  ("int" . "FIXNUM")
  ("long" . "FIXNUM")
  ("boolean" . "BOOLEAN")
))
  

(defun write-header (alg stream)
;;  (format stream "sound_type snd_make_~A();~%" (get-slot alg 'name))
    (let ((arguments (get-slot alg 'arguments))
      (name (get-slot alg 'name)))
       (format stream "sound_type snd_make_~A" name)
       (write-ansi-prototype-list stream "" arguments)
       (format stream ";~%")

       ; write the xlisp interface routine
       (format stream "sound_type snd_~A" name)
       (write-ansi-prototype-list stream "" arguments)
       (format stream ";~%")

       ; write the type specification for intgen
       (format stream "    /* LISP: (snd-~A" name)
       (dolist (arg arguments)
     (let ((xltype (assoc (car arg) c-to-xlisp-type :test #'equal)))
       (cond ((null xltype)
          (error "couldn't translate c-type" (car arg))))
       (format stream " ~A" (cdr xltype))))
       (format stream ") */~%")))


;;**********
;; write-typedef -- compile the suspension type definition
;;
;; Inputs:
;;	alg - the algorithm specification
;;	stream - stream to which to write it
;; Effect:
;;	typedef struct NAME_susp_struct {
;;		...
;;	} NAME_susp_node, *NAME_susp_type;
;;
;;  A side-effect of write-typedef is the initialization
;;  of slot xlisp-pointers in alg.  This is used later by
;;  write-mark to generate the garbage collection mark routine.
;;**********

(defun write-typedef (alg stream)
  (let (arg-type args interpolation-list sound-names arg
    (alg-name (get-slot alg 'name))
    name xlisp-pointers
    (state-list (get-slot alg 'state))
    (logical-stop (car (get-slot alg 'logical-stop)))
    (terminate (car (get-slot alg 'terminate))))
    ;----------------------------
    ;  typedef struct NAME_susp_strct {
     ;     snd_susp_node susp;
    ;----------------------------
    (format stream "~%~%typedef struct ~A_susp_struct {~%~A~%"
    alg-name "    snd_susp_node susp;")

    ; go through interpolation list:
    ;   NONE means use each sample
    ;   INTERP means interpolate between samples
    ;   RAMP means do ramp generation between samples
    ;   NIL means this is not a signal

    (setf interpolation-list (get-slot alg 'interpolation-list))
    (setf sound-names (get-slot alg 'sound-names))

    ; declare started flag if there is a ramp or interp signal anywhere
    (cond ((any-ramp-or-interp-in interpolation-list)
           ;---------------------
       ; INTERP/RAMP:
       ;	boolean started;
           ;---------------------
       (format stream "    boolean started;~%")))

    (display "in translate.lsp" 
         terminate alg (terminate-check-needed terminate alg))
    (cond ((terminate-check-needed terminate alg)
       ;----------------
       ; long terminate_cnt;
       ;----------------
       (format stream "    long terminate_cnt;~%")))

    (cond ((logical-stop-check-needed logical-stop)
       ;----------------
       ; boolean logically_stopped;
       ;----------------
       (format stream
        "    boolean logically_stopped;~%")))

    ; each sound argument has a variety of ways it might be
    ; interpolated.  These are stored on interpolation-list, and union-of-nth
     ; is used to gather all the interpolation styles that must be supported 
     ; for a given signal - we then declare whatever state is necessary for
     ; each possible interpolation
    (dotimes (n (length (get alg 'sound-args)))
      (let ((interpolation (union-of-nth interpolation-list n)))
    (setf name (nth n sound-names))	; get name of signal
    ;------------------------
    ;	sound_type NAMEi;
    ;	long  NAME_cnt;
    ;       sample_block_values_type NAME_ptr;
    ;------------------------
    (format stream "    sound_type ~A;~%" name)
    (format stream "    long ~A_cnt;~%" name)
    (format stream "    sample_block_values_type ~A_ptr;~%" name)
    (cond ((or (member 'INTERP interpolation)
           (member 'RAMP interpolation))
           ;-----------------
           ;  /* support for interpolation of NAMEi */
           ;-----------------
           (format stream 
        "~%    /* support for interpolation of ~A */~%" name)

           ;-----------------
           ;  sample_type NAME_x1_sample;
           ;-----------------
           (format stream "    sample_type ~A_x1_sample;~%" name)

           ;-----------------
           ; double NAME_pHaSe;
           ; double NAME_pHaSe_iNcR;
           ;-----------------
           (format stream "    double ~A_pHaSe;~%" name)
           (format stream "    double ~A_pHaSe_iNcR;~%" name)))

    (cond ((member 'RAMP interpolation)
           ;-----------------
           ; RAMP:
           ;	/* support for ramp between samples of NAME */
           ;	double output_per_NAME;
           ; long NAME_n;
           ;-----------------
           (format stream
        "~%    /* support for ramp between samples of ~A */~%" name)
           (format stream "    double output_per_~A;~%" name)
           (format stream "    long ~A_n;~%" name) ))))

    ;----------------------------
    ; STATE
    ; 	TYPEi VARNAMEi ;
    ;----------------------------
    ;; now write state variables
    ;; (STATE (s1) (s2)... (sn) )
    ;; each (si) is of the form
    ;;		("type" "varname" "?" [TEMP])
    (cond (state-list (format stream "~%")))
    (dolist (state state-list)
      (cond ((equal "LVAL" (car state))
         (push (cadr state) xlisp-pointers)))
      (cond ((and (cdddr state)
          (cadddr state)
          (eq (cadddr state) 'TEMP))
         ; no field allocated for local/temp variables
        )
         (t
         (let ((sep (space-if-no-trailing-star (car state))))
           (format stream "    ~A~A~A;~%" 
        (car state) sep (cadr state))))))
    (put-slot alg xlisp-pointers 'xlisp-pointers)

    ;----------------------------
    ;	} ALG-NAME_susp_node, *ALG-NAME_susp_type;
    ;----------------------------
    (format stream "} ~A_susp_node, *~A_susp_type;~%" alg-name alg-name)))

(print 'end)