home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 February / MAC_easy_02_2010.iso / Software / Multimedia / audacity-macosx-ub-1.3.11.dmg / nyquist / misc.lsp < prev    next >
Encoding:
Lisp/Scheme  |  2010-01-16  |  5.1 KB  |  155 lines

  1. ;## misc.lsp -- a collection of useful support functions
  2.  
  3. ;; Garbage collection "improvement" -- XLISP will GC without allocation
  4. ;; as long as it does not run out of cells. This can make it very slow
  5. ;; since GC does work proportional to the heap size. If there were
  6. ;; always at least, say, 1/3 of the heap free after GC, then allocating
  7. ;; cells would be more-or-less a constant time operation (amortized).
  8. ;;
  9. ;; So, after GC, we'll expand until we have 1/3 of the heap free.
  10. ;;
  11. (defun ny:gc-hook (heap-size free-cells)
  12.   (cond ((< (* free-cells 2) heap-size) ;; free cells is < 1/3 heap
  13.          ;; expand. Each expansion unit is 2000 cons cells
  14.          (let* ((how-many-not-free (- heap-size free-cells))
  15.                 (should-be-free (/ how-many-not-free 2))
  16.                 (how-many-more (- should-be-free free-cells))
  17.                 (expand-amount (/ how-many-more 2000)))
  18.            (cond ((> expand-amount 0)
  19.                   (if *gc-flag*
  20.                       (format t
  21.                        "[ny:gc-hook allocating ~A more cells] "
  22.                        (* expand-amount 2000)))
  23.                   (expand expand-amount)))))))
  24.  
  25. (setf *gc-hook* 'ny:gc-hook)
  26.  
  27.  
  28. ; set global if not already set
  29. ;
  30. (defmacro init-global (symb expr)
  31.   `(if (boundp ',symb) ,symb (setf ,symb ,expr)))
  32.  
  33. ; enable or disable breaks
  34. (defun bkon () (setq *breakenable* T))
  35. (defun bkoff () (setq *breakenable* NIL))
  36.  
  37. (bkon)
  38.  
  39. ;; (grindef 'name) - pretty print a function
  40. ;;
  41. (defun grindef (e) (pprint (get-lambda-expression (symbol-function e))))
  42.  
  43. ;; (args 'name) - print function and its formal arguments
  44. ;;
  45. (defun args (e) 
  46.   (pprint (cons e (second (get-lambda-expression (symbol-function e))))))
  47.  
  48. ;; (incf <place>), (decf <place>) - add/sub 1 to/from variable
  49. ;;
  50. (defmacro incf (symbol) `(setf ,symbol (1+ ,symbol)))
  51. (defmacro decf (symbol) `(setf ,symbol (1- ,symbol)))
  52.  
  53.  
  54. ;; (push val <place>) - cons val to list
  55. ;;
  56. (defmacro push (val lis) `(setf ,lis (cons ,val ,lis)))
  57. (defmacro pop (lis) `(prog1 (car ,lis) (setf ,lis (cdr ,lis))))
  58.  
  59. ;; include this to use RBD's XLISP profiling hooks
  60. ;;(load "/afs/andrew/usr/rbd/lib/xlisp/profile.lsp")
  61.  
  62. ;(cond ((boundp 'application-file-name)
  63. ;       (load application-file-name)))
  64.  
  65.  
  66. (defun get-input-file-name ()
  67.   (let (fname)
  68.     (format t "Input file name: ")
  69.     (setf fname (read-line))
  70.     (cond ((equal fname "") (get-input-file-name))
  71.           (t fname))))
  72.  
  73.  
  74. (defun open-output-file ()
  75.   (let (fname)
  76.     (format t "Output file name: ")
  77.     (setf fname (read-line))
  78.     (cond ((equal fname "") t)
  79.           (t (open fname :direction :output)))))
  80.  
  81.  
  82. (defmacro while (cond &rest stmts)
  83.   `(prog () loop (if ,cond () (return)) ,@stmts (go loop)))
  84.  
  85.  
  86. ; when parens/quotes don't match, try this
  87. (defun file-sexprs ()
  88.   (let ((fin (open (get-input-file-name)))
  89.         inp)
  90.     (while (setf inp (read fin)) (print inp))))
  91.  
  92. ;; get path for currently loading file (if any)
  93. ;;
  94. (defun current-path ()
  95.   (let (fullpath n)
  96.     (setf n -1)
  97.     (cond (*loadingfiles*
  98.            (setf fullpath (car *loadingfiles*))
  99.            (dotimes (i (length fullpath))
  100.              (cond ((equal (char fullpath i) *file-separator*)
  101.                     (setf n i))))
  102.            (setf fullpath (subseq fullpath 0 (1+ n)))
  103.  
  104. ;;         REMOVED SUPPORT FOR MAC OS-9 AND BELOW -RBD
  105.            ;; if this is a Mac, use ':' in place of empty path
  106. ;;           (cond ((and (equal fullpath "") 
  107. ;;                       (equal *file-separator* #\:))
  108. ;;                  (setf fullpath ":")))
  109. ;;         END MAC OS-9 CODE
  110.  
  111.            ;; Here's an interesting problem: fullpath is now the path
  112.            ;; specified to LOAD, but it may be relative to the current
  113.            ;; directory. What if we want to load a sound file from the
  114.            ;; current directory? It seems that S-READ gives priority to
  115.            ;; the *DEFAULT-SF-DIR*, so it will follow fullpath STARTING
  116.            ;; FROM *DEFAULT-SF-DIR*. To fix this, we need to make sure
  117.            ;; that fullpath is either an absolute path or starts with
  118.            ;; and explicit ./ which tells s-read to look in the current
  119.            ;; directory.
  120.            (cond ((> (length fullpath) 0)
  121.           (cond ((full-name-p fullpath))
  122.             (t ; not absolute, make it explicitly relative
  123.              (setf fullpath (strcat "./" fullpath)))))
  124.                  (t (setf fullpath "./"))) ; use current directory
  125.            fullpath)
  126.           (t nil))))
  127.           
  128. ;; real-random -- pick a random real from a range
  129. ;;
  130. (defun real-random (from to)
  131.   (+ (* (rrandom) (- to from)) from))
  132.  
  133. ;; power -- raise a number to some power x^y
  134. ;;
  135. (defun power (x y)
  136.   (exp (* (log (float x)) y)))
  137.   
  138. ;; require-from -- load a file if a function is undefined
  139. ;;
  140. ;; fn-symbol -- the function defined when the file is loaded
  141. ;; file-name -- the name of file to load if fn-symbol is undefined
  142. ;; path -- if t, load from current-path; if a string, prepend string
  143. ;;         to file-name; if nil, ignore it
  144. ;;
  145. (defmacro require-from (fn-symbol file-name &optional path)
  146.   (cond ((eq path t)
  147.          (setf file-name `(strcat (current-path) ,file-name)))
  148.         (path
  149.          (setf file-name `(strcat ,path ,file-name))))
  150.   `(if (fboundp (quote ,fn-symbol))
  151.        t
  152.        (load ,file-name)))
  153.  
  154.