home *** CD-ROM | disk | FTP | other *** search
/ ftp.uni-stuttgart.de/pub/systems/acorn/ / Acorn.tar / Acorn / acornet / dev / xlisp+ / xlisp+.spk / lsp / common < prev    next >
Lisp/Scheme  |  1992-10-02  |  11KB  |  346 lines
  1. ;; functions missing that are part of common lisp, and commonly used
  2.  
  3. ;; It is assumed you are using XLISP with all Common Lisp related options
  4. ;; turned on before you load this file.
  5.  
  6. ;; Author either unknown or Tom Almy unless indicated.
  7.  
  8. ;; pairlis does not check for lengths of keys and values being unequal
  9.  
  10. (defun pairlis (keys values &optional list)
  11.        (nconc (mapcar #'cons keys values) list))
  12.  
  13. (defun copy-list (list) (append list 'nil))
  14.  
  15. (defun copy-alist (list)
  16.     (if (null list)
  17.         'nil
  18.         (cons (if (consp (car list))
  19.           (cons (caar list) (cdar list))
  20.           (car list))
  21.           (copy-alist (cdr list)))))
  22.  
  23. (defun copy-tree (list)
  24.     (if (consp list)
  25.         (cons (copy-tree (car list)) (copy-tree (cdr list)))
  26.         list))
  27.  
  28. (defun identity (l) l)
  29.  
  30. (defun signum (x)
  31.    (cond ((not (numberp x)) (error "not a number" x))
  32.          ((zerop x) x)
  33.      (T (/ x (abs x)))))  
  34.  
  35. ; Cruddy but simple versions of these functions.
  36. ; Commented out since XLISP will now expand macros once, making
  37. ; good version much preferred.
  38.  
  39. ;(defmacro incf (var &optional (delta 1))
  40. ;    `(setf ,var (+ ,var ,delta)))
  41.  
  42. ;(defmacro decf (var &optional (delta 1))
  43. ;    `(setf ,var (- ,var ,delta)))
  44.  
  45. ;(defmacro push (v l)
  46. ;    `(setf ,l (cons ,v ,l))))
  47.  
  48. ;(defmacro pushnew (a l &rest args)
  49. ;  `(unless (member ,a ,l ,@args) (push ,a ,l) nil))
  50.  
  51. ;(defmacro pop (l)
  52. ;    `(prog1 (first ,l) (setf ,l (rest ,l)))))
  53.  
  54.  
  55. ; This is what one really needs to do for incf decf and
  56. ; (in common.lsp) push and pop. The setf form must only be evaluated once.
  57. ; But is it worth all this overhead for correctness?
  58. ; (By Tom Almy)
  59.  
  60. (defun |DoForm| (form) ; returns (cons |list for let| |new form|)
  61.        (let* ((args (rest form)) ; raw form arguments
  62.           (letlist (mapcan #'(lambda (x) (when (consp x)
  63.                            (list (list (gensym) x))))
  64.                    form))
  65.           (revlist (mapcar #'(lambda (x) (cons (second x) (first x)))
  66.                    letlist))
  67.           (newform (cons (first form) (sublis revlist args))))
  68.          (cons letlist newform)))
  69.  
  70. (defmacro incf (form &optional (delta 1))
  71.       (if (and (consp form) (some #'consp form))
  72.           (let ((retval (|DoForm| form)))
  73.            `(let ,(car retval) 
  74.              (setf ,(cdr retval)
  75.                    (+ ,(cdr retval) ,delta))))
  76.           `(setf ,form (+ ,form ,delta))))
  77.  
  78. (defmacro decf (form &optional (delta 1))
  79.       (if (and (consp form) (some #'consp form))
  80.           (let ((retval (|DoForm| form)))
  81.            `(let ,(car retval) 
  82.              (setf ,(cdr retval)
  83.                    (- ,(cdr retval) ,delta))))
  84.           `(setf ,form (- ,form ,delta))))
  85.  
  86. (defmacro push (val form)
  87.       (if (and (consp form) (some #'consp form))
  88.           (let ((retval (|DoForm| form)))
  89.            `(let ,(car retval) 
  90.              (setf ,(cdr retval)
  91.                    (cons ,val ,(cdr retval)))))
  92.           `(setf ,form (cons ,val ,form))))
  93.  
  94. (defmacro pop (form)
  95.       (if (and (consp form) (some #'consp form))
  96.           (let ((retval (|DoForm| form)))
  97.            `(let ,(car retval) 
  98.              (prog1 (first ,(cdr retval))
  99.                 (setf ,(cdr retval)
  100.                       (rest ,(cdr retval))))))
  101.           `(prog1 (first ,form)
  102.               (setf ,form (rest ,form)))))
  103.  
  104.  
  105. (defmacro pushnew (val form &rest rest)
  106.       (if (and (consp form) (some #'consp form))
  107.           (let ((retval (|DoForm| form)))
  108.            `(let ,(car retval) 
  109.              (setf ,(cdr retval)
  110.                    (adjoin ,val ,(cdr retval) ,@rest))))
  111.           `(setf ,form (adjoin ,val ,form ,@rest))))
  112.  
  113.  
  114. ;; Hyperbolic functions    Ken Whedbee  from CLtL
  115.  
  116. (defun logtest (x y) (not (zerop (logand x y))))
  117.  
  118. (defconstant imag-one #C(0.0 1.0))
  119.  
  120. (defun cis (x) (exp (* imag-one x)))
  121.  
  122.  
  123. (defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0))
  124. (defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0))
  125. (defun tanh (x) (/ (sinh x) (cosh x)))
  126.  
  127. (defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
  128. (defun acosh (x)
  129.        (log (+ x
  130.                (* (1+ x)
  131.                     (sqrt (/ (1- x) (1+ x)))))))
  132. (defun atanh (x)
  133.        (when (or (= x 1.0) (= x -1.0))
  134.              (error "logarithmic singularity" x))
  135.        (log (/ (1+ x) (sqrt (- 1.0 (* x x))))))
  136.     
  137.  
  138.  
  139. ;; Additional Common Lisp Functions by Luke Tierney
  140. ;; from xlisp-stat
  141.  
  142. ;;
  143. ;; Defsetf and documentation functions
  144. ;; Corrected for Common Lisp compatibility (requires XLISP-PLUS 2.1e)
  145. ;;  Modified by Tom Almy, 7/92
  146. ;;
  147.  
  148. (defun apply-arg-rotate (f args) 
  149.   (apply f (car (last args)) (butlast args)))
  150.  
  151. ; (defsetf) - define setf method
  152. (defmacro defsetf (sym first &rest rest)
  153.   (if (symbolp first)
  154.       `(progn (setf (get ',sym '*setf*) #',first) ',sym)
  155.       (let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
  156.             (args (gensym)))
  157.         `(progn
  158.           (setf (get ',sym '*setf-lambda*) ; changed *setf* to *setf-lambda*
  159.                 #'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
  160.           ',sym))))
  161.  
  162.   
  163. ;;;;
  164. ;;;;
  165. ;;;; Modules, provide and require:  Luke Tierney, from xlisp-stat
  166. ;;;;
  167. ;;;;
  168.  
  169. ; Uncomment these if you want them. It's non-standard, and nothing else
  170. ; in this distribution  uses them, so I'm commenting them out.  Tom Almy
  171.  
  172. ;(defvar *modules*)
  173.     
  174. ;(defun provide (name)
  175. ;  (pushnew name *modules* :test #'equal))
  176.   
  177. ;(defun require (name &optional (path name))
  178. ;  (let ((name (string name))
  179. ;        (path (string path)))
  180. ;    (unless (member name *modules* :test #'equal)
  181. ;            (if (load path)
  182. ;                t
  183. ;        (load (strcat *default-path* path))))))
  184.  
  185. ;;;;
  186. ;;;;
  187. ;;;; Miscellaneous Functions:  Luke Tierney
  188. ;;;;    from xlisp-stat
  189. ;;;;
  190.  
  191. ;(defun vectorp (x)
  192. ;  (and (arrayp x) (= (array-rank x) 1)))
  193.  
  194. ; equalp rewritten by Tom Almy to better match Common Lisp
  195. (defun equalp (x y)
  196.   (cond ((equal x y) t)
  197.       ((numberp x) (if (numberp y) (= x y) nil))
  198.       ((characterp x) (if (characterp y) (char-equal x y) nil))
  199.       ((and (or (arrayp x) (stringp x)) 
  200.             (or (arrayp y) (stringp y))
  201.             (eql (length x) (length y)))
  202.        (every #'equalp x y))))
  203.  
  204. ; also improved by TAA to use *terminal-io*
  205. (defun y-or-n-p (&rest args)
  206.   (do ((answer nil 
  207.            (let* ((*breakenable* nil)
  208.               (x (errset (read *terminal-io*) nil)))
  209.              (when (consp x) (car x)))))
  210.       ((member answer '(y n)) (eq answer 'y))
  211.       (when args (apply #'format *terminal-io* args))
  212.       (princ " (Y/N)" *terminal-io*)))
  213.  
  214. ; This implementation is questionable (says TAA), I'm commenting it out
  215.  
  216. ; (defun getf (place indicator &optional default)
  217. ;   (let ((mem (member indicator place :test #'eq)))
  218. ;    (if mem (second mem) default)))
  219.  
  220.  
  221. ; Improved by TAA to match common lisp definition
  222. (defun functionp (x)
  223.     (if (typep x '(or closure subr symbol))
  224.     t
  225.         (and (consp x) (eq (car x) 'lambda))))
  226.  
  227. (defmacro with-input-from-string (stream-string &rest body)
  228.   (let ((stream (first stream-string))
  229.         (string (second stream-string)))
  230.     `(let ((,stream (make-string-input-stream ,string)))
  231.        (progn ,@body))))
  232.  
  233.  
  234. (defmacro with-input-from-string
  235.       (stream-string &rest body)
  236.       (let ((stream (first stream-string))
  237.         (string (second stream-string))
  238.         (start (second (member :start (cddr stream-string))))
  239.         (end (second (member :end (cddr stream-string))))
  240.         (index (second (member :index (cddr stream-string)))))
  241.            (when (null start) (setf start 0))
  242.            (if index
  243.            (let ((str (gensym)))
  244.             `(let* ((,str ,string)
  245.                 (,stream (make-string-input-stream ,str 
  246.                                    ,start 
  247.                                    ,end)))
  248.                (prog1 (progn ,@body)
  249.                   (setf ,index 
  250.                     (- (length ,str)
  251.                        (length (get-output-stream-list 
  252.                              ,stream)))))))
  253.            `(let ((,stream (make-string-input-stream ,string ,start ,end)))
  254.              (progn ,@body)))))
  255.            
  256.  
  257. (defmacro with-output-to-string (str-list &rest body)
  258.   (let ((stream (first str-list)))
  259.     `(let ((,stream (make-string-output-stream)))
  260.        (progn ,@body)
  261.        (get-output-stream-string ,stream))))
  262.  
  263. (defmacro with-open-file (stream-file-args &rest body)
  264.   (let ((stream (first stream-file-args))
  265.         (file-args (rest stream-file-args)))
  266.     `(let ((,stream (open ,@file-args)))
  267.        (unwind-protect 
  268.            (progn ,@body)
  269.          (when ,stream (close ,stream))))))
  270.  
  271. ; (unintern sym) - remove a symbol from the oblist
  272. (defun unintern (symbol)
  273.   (let ((subhash (hash symbol (length *obarray*))))
  274.     (cond ((member symbol (aref *obarray* subhash))
  275.              (setf (aref *obarray* subhash)
  276.                    (delete symbol (aref *obarray* subhash)))
  277.              t)
  278.           (t nil))))
  279.  
  280.  
  281. ;; array functions.   KCW    from  Kyoto Common Lisp
  282.  
  283. (defun fill (sequence item
  284.              &key (start 0) end)
  285.        (when (null end) (setf end (length sequence)))
  286.        (do ((i start (1+ i)))
  287.        ((>= i end) sequence)
  288.        (setf (elt sequence i) item)))
  289.  
  290.  
  291. (defun replace (sequence1 sequence2
  292.                 &key (start1 0) end1
  293.                      (start2 0) end2)
  294.     (when (null end1) (setf end1 (length sequence1)))
  295.     (when (null end2) (setf end2 (length sequence2)))
  296.     (if (and (eq sequence1 sequence2)
  297.              (> start1 start2))
  298.         (do* ((i 0 (1+ i))
  299.               (l (if (< (- end1 start1) (- end2 start2))
  300.                      (- end1 start1)
  301.                      (- end2 start2)))
  302.               (s1 (+ start1 (1- l)) (1- s1))
  303.               (s2 (+ start2 (1- l)) (1- s2)))
  304.             ((>= i l) sequence1)
  305.           (setf (elt sequence1 s1) (elt sequence2 s2)))
  306.         (do ((i 0 (1+ i))
  307.              (l (if (< (- end1 start1)(- end2 start2))
  308.                     (- end1 start1)
  309.                     (- end2 start2)))
  310.              (s1 start1 (1+ s1))
  311.              (s2 start2 (1+ s2)))
  312.             ((>= i l) sequence1)
  313.           (setf (elt sequence1 s1) (elt sequence2 s2)))))
  314.  
  315.  
  316. (defun acons (x y a)         ; from CLtL
  317.    (cons (cons x y) a))
  318.  
  319.  
  320. ;; more set functions.  KCW    from Kyoto Common Lisp
  321.  
  322. ;; Modified to pass keys to subfunctions without checking here
  323. ;; (more efficient)
  324.  
  325. ;; (Tom Almy states:) we can't get the destructive versions of union
  326. ;; intersection, and set-difference to run faster than the non-destructive
  327. ;; subrs. Therefore we will just have the destructive versions do their
  328. ;; non-destructive counterparts
  329.  
  330. (setf (symbol-function 'nunion) 
  331.       (symbol-function 'union)
  332.       (symbol-function 'nintersection) 
  333.       (symbol-function 'intersection)
  334.       (symbol-function 'nset-difference) 
  335.       (symbol-function 'set-difference))
  336.  
  337. (defun set-exclusive-or (list1 list2 &rest rest)
  338.   (append (apply #'set-difference list1 list2 rest)
  339.           (apply #'set-difference list2 list1 rest)))
  340.  
  341. (defun nset-exclusive-or (list1 list2 &rest rest)
  342.   (nconc (apply #'set-difference list1 list2 rest)
  343.          (apply #'set-difference list2 list1 rest)))
  344.  
  345. (push :common *features*)
  346.