home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / apteryx / gen.lsp < prev    next >
Lisp/Scheme  |  1994-04-09  |  5KB  |  169 lines
  1. ; general lisp functions 
  2. ; Copyright 1994 Apteryx Lisp Ltd
  3.  
  4. (setq *is-apteryx* (boundp '*apteryx-if-bound*))
  5.  
  6. (defun get-no-fail (sym prop)
  7.   (let ( (value (get sym prop)) )
  8.     (if (not value)
  9.       (error "Failure to retrieve property" (list sym prop)) )
  10.     value) )
  11.  
  12. (defmacro pr (name &optional where)
  13.   `(progn
  14.      ,@(if where
  15.        `((format t "~A: " ',where)) )
  16.      (format t "~S = ~S~%" ',name ,name)
  17.      ,name) )
  18.  
  19. (defmacro push (list el)
  20.   `(setq ,list (cons ,el ,list)) )
  21.  
  22. (defmacro pop (list)
  23.   `(setq ,list (cdr ,list)) )
  24.  
  25. (defun flatten (list)
  26.   (let ( (out nil) )
  27.     (dolist (elt list)
  28.       (if (listp elt)
  29.         (setq out (append (reverse (flatten elt)) out))
  30.         (setq out (cons elt out)) ) )
  31.     (reverse out) ) )
  32.  
  33. ; (flatten '(a ((b c)) (d e) (f (g h)) (i) () j k))
  34.  
  35. (defun quoted (x)
  36.   (list 'quote x))
  37.  
  38. (defconstant decimal-digits (vector "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
  39.  
  40. (defun ordinal (n)
  41.   (strcat (prin1-to-string n)
  42.     (let ( (n100 (rem n 100)) )
  43.       (if (and (> n100 10) (< n100 20))
  44.         "th"
  45.         (case (rem n 10)
  46.           (1 "st")
  47.           (2 "nd")
  48.           (3 "rd")
  49.           (t "th") ) ) ) ) )
  50. ;(ordinal 31)
  51.  
  52. (defmacro with-open-file (name stream direc &rest exprs)
  53.   `(let ((,stream (open ,name :direction ,direc)))
  54.      (if ,stream
  55.        (unwind-protect
  56.          (progn ,@exprs)
  57.          (close ,stream) )
  58.        (error "Failure to open file" name) ) ) )
  59.  
  60. (defun print-spaces (n)
  61.   (dotimes (i n) (princ " ")) )
  62.  
  63. (defun and-fun (&rest args)
  64.   (eval (cons 'and args)) )
  65.  
  66. (defun lines-of-file (filename)
  67.   (let ( (list nil) )
  68.     (with-open-file filename file :input
  69.       (while (not (eofp file))
  70.         (let ( (line (read-line file)) )
  71.           (if (stringp line)
  72.             (setq list (cons line list)) ) ) ) )
  73.     (reverse list) ) )
  74.  
  75. ;;; sorting
  76.  
  77. (defun split-list (list)
  78.   (let ( (list1 nil) (list2 nil) (list3 nil))
  79.     (dolist (elt (reverse list))
  80.       (setq list3 (cons elt list1))
  81.       (setq list1 list2)
  82.       (setq list2 list3) )
  83.     (cons list2 list1) ) )
  84.  
  85. ; (split-list '(1 2 3 4 5 6 7 8))
  86.  
  87. (defun merged (list1 list2 less-than)
  88.   (let ( (result nil) (rem-list1 list1) (rem-list2 list2) next-elt)
  89.     (while (or rem-list1 rem-list2)
  90.       (if (or (null rem-list2)
  91.             (and rem-list1
  92.               (funcall less-than (car rem-list1) (car rem-list2)) ) )
  93.         (progn
  94.           (setq next-elt (car rem-list1))
  95.           (setq rem-list1 (cdr rem-list1)) )
  96.         (progn
  97.           (setq next-elt (car rem-list2))
  98.           (setq rem-list2 (cdr rem-list2)) ) )
  99.       (setq result (cons next-elt result)) )
  100.     (reverse result) ) )
  101.  
  102. (merged '(1 3 5) '(2 6 8) #'<)
  103.  
  104. (defun merge-sort (list less-than)
  105.   (if (<= (length list) 1)
  106.     list
  107.     (let* ( (halves (split-list list))
  108.             (list1-sorted (merge-sort (car halves) less-than))
  109.             (list2-sorted (merge-sort (cdr halves) less-than)) )
  110.       (merged list1-sorted list2-sorted less-than) ) ) )
  111.  
  112. (defun sort (list less-than)
  113.   (merge-sort list less-than) )
  114.       
  115. ; (sort '(5 7 1 5 10 20 300 -5 71 3 8 9) #'<)
  116.  
  117. ; fake progv - main difference is that there is no
  118. ; distinction between dynamic and global value.
  119.  
  120. ;;; A simple trace facility
  121.  
  122. ; Usage   (trace fun1 fun2)   trace functions
  123. ;         (trace)             see list of traced functions
  124. ;         (untrace fun1 fun2) stop tracing functions
  125. ;         (untrace)           untrace all traced functions
  126.  
  127.  
  128. ;(defun square (x) (* x x))
  129.  
  130. ;(square 100)
  131.  
  132. ;(trace square) (untrace square) (trace) (untrace)
  133.  
  134. (setq *traced-functions* nil)
  135.  
  136. (defun trace1 (fun)
  137.   (if (not (get fun 'original-function))
  138.     (let ( (fun-value (symbol-function fun)) )
  139.       (setf (symbol-function fun)
  140.         #'(lambda (&rest args)
  141.             (format t "Applying fun #'~A to args ~A~%" fun args)
  142.             (let ( (result (apply fun-value args)) )
  143.               (format t "Applied fun #'~A to args ~A => ~A~%"
  144.                 fun args result)
  145.               result) ) )
  146.       (setf (get fun 'original-function) fun-value)
  147.       (setq *traced-functions* (cons fun *traced-functions*))
  148.       fun) ) )
  149.  
  150. (defun untrace1 (fun)
  151.   (let ( (original-fun (get fun 'original-function)) )
  152.     (when original-fun
  153.       (setf (symbol-function fun) original-fun)
  154.       (remprop fun 'original-function)
  155.       (setq *traced-functions* (remove fun *traced-functions*)) ) )
  156.   fun)
  157.  
  158. (defmacro trace (&rest funs)
  159.   `(if ',funs
  160.      (mapcar #'trace1 ',funs)
  161.      (format t "Traced functions: ~A~%" *traced-functions*) ) )
  162.  
  163. (defmacro untrace (&rest funs)
  164.   `(if ',funs
  165.      (mapcar #'untrace1 ',funs)
  166.      (mapcar #'untrace1 *traced-functions*) ) )
  167.  
  168. (load "gen2.lsp")
  169.