home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / xlisp / xl21freq.zip / COMMON.LSP < prev    next >
Lisp/Scheme  |  1993-12-17  |  18KB  |  579 lines
  1. ;; functions missing that are part of common lisp, and commonly used
  2.  
  3. ;; It is assumed you are using XLISP 2.1f 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. (in-package "XLISP")
  9.  
  10. ; (unintern sym) - remove a symbol from the oblist
  11. #-:packages
  12. (defun unintern (symbol)
  13.   (let ((subhash (hash symbol (length *obarray*))))
  14.     (cond ((member symbol (aref *obarray* subhash))
  15.              (setf (aref *obarray* subhash)
  16.                    (delete symbol (aref *obarray* subhash)))
  17.              t)
  18.           (t nil))))
  19.  
  20. (export '(pairlis copy-list copy-alist copy-tree signum))
  21.  
  22. ;; pairlis does not check for lengths of keys and values being unequal
  23.  
  24. (defun pairlis (keys values &optional list)
  25.        (nconc (mapcar #'cons keys values) list))
  26.  
  27. (defun copy-list (list) (append list 'nil))
  28.  
  29. (defun copy-alist (list)
  30.     (if (null list)
  31.         'nil
  32.         (cons (if (consp (car list))
  33.           (cons (caar list) (cdar list))
  34.           (car list))
  35.           (copy-alist (cdr list)))))
  36.  
  37. (defun copy-tree (list)
  38.     (if (consp list)
  39.         (cons (copy-tree (car list)) (copy-tree (cdr list)))
  40.         list))
  41.  
  42. (defun signum (x)
  43.    (cond ((not (numberp x)) (error "~s is not a number" x))
  44.          ((zerop x) x)
  45.      (T (/ x (abs x)))))  
  46.  
  47. (export '(remf incf decf push pushnew pop))
  48.  
  49. ; Cruddy but simple versions of these functions.
  50. ; Commented out since XLISP will now expand macros once, making
  51. ; good version much preferred.
  52.  
  53. ;(defmacro incf (var &optional (delta 1))
  54. ;    `(setf ,var (+ ,var ,delta)))
  55.  
  56. ;(defmacro decf (var &optional (delta 1))
  57. ;    `(setf ,var (- ,var ,delta)))
  58.  
  59. ;(defmacro push (v l)
  60. ;    `(setf ,l (cons ,v ,l))))
  61.  
  62. ;(defmacro pushnew (a l &rest args)
  63. ;  `(unless (member ,a ,l ,@args) (push ,a ,l) nil))
  64.  
  65. ;(defmacro pop (l)
  66. ;    `(prog1 (first ,l) (setf ,l (rest ,l)))))
  67.  
  68.  
  69. ; This is what one really needs to do for incf decf and
  70. ; (in common.lsp) push and pop. The setf form must only be evaluated once.
  71. ; But is it worth all this overhead for correctness?
  72. ; (By Tom Almy)
  73.  
  74. (defun |DoForm| (form) ; returns (cons |list for let| |new form|)
  75.        (let* ((args (rest form)) ; raw form arguments
  76.           (letlist (mapcan #'(lambda (x) (when (consp x)
  77.                            (list (list (gensym) x))))
  78.                    form))
  79.           (revlist (mapcar #'(lambda (x) (cons (second x) (first x)))
  80.                    letlist))
  81.           (newform (cons (first form) (sublis revlist args))))
  82.          (cons letlist newform)))
  83.  
  84. (defun |RemProp| (l prop)
  85.        (do ((cl l (cddr cl))
  86.         (flg nil cl))
  87.        ((atom cl) nil)    ; none found 
  88.        (cond ((atom (cdr l)) 
  89.           (error "odd length property list"))
  90.          ((eq (car cl) prop) ; a match!
  91.           (if flg ; different if first in list from later 
  92.               (rplacd (cdr flg) (cddr cl))
  93.               (setq l (cddr l)))
  94.           (return (list l))))))
  95.  
  96. (defmacro remf (form prop &aux (remres (gensym)))
  97.       (if (and (consp form) (some #'consp form))
  98.           (let ((retval (|DoForm| form)))
  99.            `(let* ( ,@(car retval)
  100.                 (,remres (|RemProp| ,(cdr retval) ,prop)))
  101.               (if ,remres
  102.                   (progn (setf ,(cdr retval) (car ,remres))
  103.                      t)
  104.                   nil)))
  105.           `(let ((,remres (|RemProp| ,form ,prop)))
  106.             (if ,remres (progn (setf ,form (car ,remres)) t)
  107.             nil))))
  108.  
  109. #-packages
  110. (unintern '|RemProp|)
  111.  
  112. (defmacro incf (form &optional (delta 1))
  113.       (if (and (consp form) (some #'consp form))
  114.           (let ((retval (|DoForm| form)))
  115.            `(let ,(car retval) 
  116.              (setf ,(cdr retval)
  117.                    (+ ,(cdr retval) ,delta))))
  118.           `(setf ,form (+ ,form ,delta))))
  119.  
  120. (defmacro decf (form &optional (delta 1))
  121.       (if (and (consp form) (some #'consp form))
  122.           (let ((retval (|DoForm| form)))
  123.            `(let ,(car retval) 
  124.              (setf ,(cdr retval)
  125.                    (- ,(cdr retval) ,delta))))
  126.           `(setf ,form (- ,form ,delta))))
  127.  
  128. (defmacro push (val form)
  129.       (if (and (consp form) (some #'consp form))
  130.           (let ((retval (|DoForm| form)))
  131.            `(let ,(car retval) 
  132.              (setf ,(cdr retval)
  133.                    (cons ,val ,(cdr retval)))))
  134.           `(setf ,form (cons ,val ,form))))
  135.  
  136. (defmacro pop (form)
  137.       (if (and (consp form) (some #'consp form))
  138.           (let ((retval (|DoForm| form)))
  139.            `(let ,(car retval) 
  140.              (prog1 (first ,(cdr retval))
  141.                 (setf ,(cdr retval)
  142.                       (rest ,(cdr retval))))))
  143.           `(prog1 (first ,form)
  144.               (setf ,form (rest ,form)))))
  145.  
  146.  
  147. (defmacro pushnew (val form &rest rest)
  148.       (if (and (consp form) (some #'consp form))
  149.           (let ((retval (|DoForm| form)))
  150.            `(let ,(car retval) 
  151.              (setf ,(cdr retval)
  152.                    (adjoin ,val ,(cdr retval) ,@rest))))
  153.           `(setf ,form (adjoin ,val ,form ,@rest))))
  154.  
  155. #-packages
  156. (unintern '|DoForm|)
  157.  
  158. ;; Hyperbolic functions    Ken Whedbee  from CLtL
  159.  
  160. (export '(logtest cis sinh cosh tanh asinh acosh atanh))
  161.  
  162. (defun logtest (x y) (not (zerop (logand x y))))
  163.  
  164. (defconstant imag-one #C(0.0 1.0))
  165.  
  166. (defun cis (x) (exp (* imag-one x)))
  167.  
  168.  
  169. (defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0))
  170. (defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0))
  171. (defun tanh (x) (/ (sinh x) (cosh x)))
  172.  
  173. (defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
  174. (defun acosh (x)
  175.        (log (+ x
  176.                (* (1+ x)
  177.                     (sqrt (/ (1- x) (1+ x)))))))
  178. (defun atanh (x)
  179.        (when (or (= x 1.0) (= x -1.0))
  180.              (error "~s is a logarithmic singularity" x))
  181.        (log (/ (1+ x) (sqrt (- 1.0 (* x x))))))
  182.     
  183.  
  184.  
  185. ;; Additional Common Lisp Functions by Luke Tierney
  186. ;; from xlisp-stat
  187.  
  188. ;;
  189. ;; Defsetf and documentation functions
  190. ;; Corrected for Common Lisp compatibility (requires XLISP-PLUS 2.1e)
  191. ;;  Modified by Tom Almy, 7/92
  192. ;;  Corrected again in 6/93
  193. ;;  and again (Luke Tierney) 11/93
  194. ;;
  195.  
  196. (export '(defsetf))
  197.  
  198. (defun apply-arg-rotate (f args) 
  199.   (apply f (list 'quote (car (last args))) (butlast args)))
  200.  
  201. ; (defsetf) - define setf method
  202. (defmacro defsetf (sym first &rest rest)
  203.   (if (symbolp first)
  204.       `(progn (setf (get ',sym '*setf*) #',first)
  205.           (remprop ',sym '*setf-lambda*)
  206.           ',sym)
  207.       (let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
  208.             (args (gensym)))
  209.         `(progn
  210.           (setf (get ',sym '*setf-lambda*) ; changed *setf* to *setf-lambda*
  211.                 #'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
  212.       (remprop ',sym '*setf*)
  213.           ',sym))))
  214.  
  215.  
  216. ;;;;
  217. ;;;;
  218. ;;;; Modules, provide and require:  Luke Tierney, from xlisp-stat
  219. ;;;;
  220. ;;;;
  221.  
  222. ; Uncomment these if you want them. It's non-standard, and nothing else
  223. ; in this distribution  uses them, so I'm commenting them out.  Tom Almy
  224.  
  225. #|
  226. (defvar *modules*)
  227.     
  228. (defun provide (name)
  229.   (pushnew name *modules* :test #'equal))
  230.   
  231. (defun require (name &optional (path name))
  232.   (let ((name (string name))
  233.         (path (string path)))
  234.     (unless (member name *modules* :test #'equal)
  235.             (if (load path)
  236.                 t
  237.         (load (strcat *default-path* path))))))
  238. |#
  239. ;;;;
  240. ;;;;
  241. ;;;; Miscellaneous Functions:  Luke Tierney
  242. ;;;;    from xlisp-stat
  243. ;;;;
  244.  
  245. (export '(equalp y-or-n-p functionp with-input-from-string
  246.           with-output-to-string with-open-file))
  247.  
  248. ; equalp rewritten by Tom Almy to better match Common Lisp
  249. (defun equalp (x y)
  250.   (cond ((equal x y) t)
  251.       ((numberp x) (if (numberp y) (= x y) nil))
  252.       ((characterp x) (if (characterp y) (char-equal x y) nil))
  253.       ((and (or (arrayp x) (stringp x)) 
  254.             (or (arrayp y) (stringp y))
  255.             (eql (length x) (length y)))
  256.        (every #'equalp x y))))
  257.  
  258. ; also improved by TAA to use *terminal-io*
  259. (defun y-or-n-p (&rest args)
  260.        (reset-system)
  261.        (do ((answer nil (string-trim " "(read-line))))
  262.        ((or (string-equal answer "Y")
  263.         (string-equal answer "N"))
  264.         (string-equal answer "Y"))
  265.        (when args (apply #'format *terminal-io* args))
  266.        (princ " (Y/N)" *terminal-io*)))
  267.  
  268. ; Improved by TAA to match common lisp definition
  269. (defun functionp (x)
  270.     (if (typep x '(or closure subr symbol))
  271.     t
  272.         (and (consp x) (eq (car x) 'lambda))))
  273.  
  274. ;(defmacro with-input-from-string (stream-string &rest body)
  275. ;  (let ((stream (first stream-string))
  276. ;        (string (second stream-string)))
  277. ;    `(let ((,stream (make-string-input-stream ,string)))
  278. ;       (progn ,@body))))
  279.  
  280.  
  281. (defmacro with-input-from-string
  282.       (stream-string &rest body)
  283.       (let ((stream (first stream-string))
  284.         (string (second stream-string))
  285.         (start (second (member :start (cddr stream-string))))
  286.         (end (second (member :end (cddr stream-string))))
  287.         (index (second (member :index (cddr stream-string)))))
  288.            (when (null start) (setf start 0))
  289.            (if index
  290.            (let ((str (gensym)))
  291.             `(let* ((,str ,string)
  292.                 (,stream (make-string-input-stream ,str 
  293.                                    ,start 
  294.                                    ,end)))
  295.                (prog1 (progn ,@body)
  296.                   (setf ,index 
  297.                     (- (length ,str)
  298.                        (length (get-output-stream-list 
  299.                              ,stream)))))))
  300.            `(let ((,stream (make-string-input-stream ,string ,start ,end)))
  301.              (progn ,@body)))))
  302.            
  303.  
  304. (defmacro with-output-to-string (str-list &rest body)
  305.   (let ((stream (first str-list)))
  306.     `(let ((,stream (make-string-output-stream)))
  307.        (progn ,@body)
  308.        (get-output-stream-string ,stream))))
  309.  
  310. (defmacro with-open-file (stream-file-args &rest body)
  311.   (let ((stream (first stream-file-args))
  312.         (file-args (rest stream-file-args)))
  313.     `(let ((,stream (open ,@file-args)))
  314.        (unwind-protect 
  315.            (progn ,@body)
  316.          (when ,stream (close ,stream))))))
  317.  
  318. (export '(eval-when declare proclaim special))
  319. ;; Dummy function to allow importing CL code
  320. (defmacro eval-when (when &rest body)
  321.   (if (or (member 'eval when) (member 'execute when))
  322.       `(progn ,@body)))
  323. (defmacro declare (&rest args)
  324.   (if *displace-macros*
  325.       (dolist (a args)
  326.         (if (eq (first a) 'special)
  327.         (return (cerror "special ignored"
  328.                 "special declarations are not supported"))))))
  329. (defun proclaim (decl)
  330.   (if (eq (first decl) 'special)
  331.       (dolist (s (rest decl))
  332.         (mark-as-special s))))
  333.  
  334.  
  335. ;; array functions.   KCW    from  Kyoto Common Lisp
  336.  
  337. (export '(fill replace acons))
  338.  
  339. (defun fill (sequence item
  340.              &key (start 0) end)
  341.        (when (null end) (setf end (length sequence)))
  342.        (do ((i start (1+ i)))
  343.        ((>= i end) sequence)
  344.        (setf (elt sequence i) item)))
  345.  
  346.  
  347. (defun replace (sequence1 sequence2
  348.                 &key (start1 0) end1
  349.                      (start2 0) end2)
  350.     (when (null end1) (setf end1 (length sequence1)))
  351.     (when (null end2) (setf end2 (length sequence2)))
  352.     (if (and (eq sequence1 sequence2)
  353.              (> start1 start2))
  354.         (do* ((i 0 (1+ i))
  355.               (l (if (< (- end1 start1) (- end2 start2))
  356.                      (- end1 start1)
  357.                      (- end2 start2)))
  358.               (s1 (+ start1 (1- l)) (1- s1))
  359.               (s2 (+ start2 (1- l)) (1- s2)))
  360.             ((>= i l) sequence1)
  361.           (setf (elt sequence1 s1) (elt sequence2 s2)))
  362.         (do ((i 0 (1+ i))
  363.              (l (if (< (- end1 start1)(- end2 start2))
  364.                     (- end1 start1)
  365.                     (- end2 start2)))
  366.              (s1 start1 (1+ s1))
  367.              (s2 start2 (1+ s2)))
  368.             ((>= i l) sequence1)
  369.           (setf (elt sequence1 s1) (elt sequence2 s2)))))
  370.  
  371.  
  372. (defun acons (x y a)         ; from CLtL
  373.    (cons (cons x y) a))
  374.  
  375.  
  376. ;; more set functions.  KCW    from Kyoto Common Lisp
  377.  
  378. ;; Modified to pass keys to subfunctions without checking here
  379. ;; (more efficient)
  380.  
  381. ;; (Tom Almy states:) we can't get the destructive versions of union
  382. ;; intersection, and set-difference to run faster than the non-destructive
  383. ;; subrs. Therefore we will just have the destructive versions do their
  384. ;; non-destructive counterparts
  385.  
  386. (export '(nunion nintersection nset-difference
  387.       set-exclusive-or nset-exclusive-or))
  388.  
  389. (setf (symbol-function 'nunion) 
  390.       (symbol-function 'union)
  391.       (symbol-function 'nintersection) 
  392.       (symbol-function 'intersection)
  393.       (symbol-function 'nset-difference) 
  394.       (symbol-function 'set-difference))
  395.  
  396. (defun set-exclusive-or (list1 list2 &rest rest)
  397.   (append (apply #'set-difference list1 list2 rest)
  398.           (apply #'set-difference list2 list1 rest)))
  399.  
  400. (defun nset-exclusive-or (list1 list2 &rest rest)
  401.   (nconc (apply #'set-difference list1 list2 rest)
  402.          (apply #'set-difference list2 list1 rest)))
  403.  
  404.  
  405.  
  406. ;;;;;
  407. ;;;;; Symbol and Package Functions
  408. ;;;;;
  409. #+:packages
  410. (export '(defpackage do-symbols do-external-symbols do-all-symbols
  411.       apropos apropos-list))
  412.  
  413. #+:packages
  414. (defmacro do-symbol-arrays (s res a body)
  415.   (let ((arraysym (gensym))
  416.     (isym (gensym))
  417.     (asym (gensym))
  418.     (listsym (gensym)))     
  419.     `(let ((,arraysym ,a)
  420.        (,isym 0)
  421.        (,asym nil)
  422.        (,listsym nil)
  423.        (,s nil))
  424.        (block nil
  425.          (tagbody
  426.       new-array
  427.       (when (null ,arraysym)
  428.         (setf ,s nil)
  429.         (return ,res))
  430.       (setf ,asym (first ,arraysym) ,arraysym (rest ,arraysym) ,isym -1)
  431.       new-list
  432.       (setf ,isym (1+ ,isym))
  433.       (if (<= 199 ,isym) (go new-array))
  434.       (setf ,listsym (aref ,asym ,isym))
  435.       new-item
  436.       (if (null ,listsym) (go new-list))
  437.       (setf ,s (first ,listsym) ,listsym (rest ,listsym))
  438.       (tagbody ,@body)
  439.       (go new-item))))))
  440.  
  441. #+:packages
  442. (defmacro do-symbols (spr &rest body)
  443.   (let ((packsym (gensym))
  444.     (usessym (gensym))
  445.     (arraysym (gensym)))
  446.     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
  447.         (,usessym (package-use-list ,packsym))
  448.         (,arraysym (cons (package-obarray ,packsym nil)
  449.                  (mapcar #'package-obarray
  450.                      (cons ,packsym ,usessym)))))
  451.        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
  452.  
  453. #+:packages
  454. (defmacro do-external-symbols (spr &rest body)
  455.   (let ((packsym (gensym))
  456.     (arraysym (gensym)))
  457.     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
  458.         (,arraysym (list (package-obarray ,packsym))))
  459.        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
  460.  
  461. #+:packages
  462. (defmacro do-all-symbols (sr &rest body)
  463.   (let ((packsym (gensym))
  464.     (arraysym (gensym)))
  465.     `(let* ((,packsym (list-all-packages))
  466.         (,arraysym nil))
  467.        (dolist (p ,packsym)
  468.          (push (package-obarray p) ,arraysym)
  469.      (push (package-obarray p nil) ,arraysym))
  470.        (do-symbol-arrays ,(first sr) ,(second sr) ,arraysym ,body))))
  471.  
  472. #+:packages
  473. (defmacro defpackage (pname &rest options)
  474.   `(let* ((pname ',pname)
  475.       (options ',options)
  476.       (pack (find-package ',pname))
  477.       (nicknames nil))
  478.      (dolist (opt options)
  479.        (if (eq (first opt) :nicknames)
  480.        (setf nicknames (append (rest opt) nicknames))))
  481.      (if pack
  482.      (rename-package pack
  483.              pname
  484.              (mapcar #'string
  485.                  (append nicknames (package-nicknames pack))))
  486.          (setf pack (make-package pname :nicknames 
  487.                   (mapcar #'string nicknames))))
  488.      (dolist (opt options)
  489.        (case (first opt)
  490.          (:shadow (shadow (mapcar #'string (rest opt)) pack))
  491.      (:shadowing-import-from
  492.       (let ((from-pack (find-package (second opt))))
  493.         (dolist (sname (rest (rest opt)))
  494.           (multiple-value-bind (sym found)
  495.                    (find-symbol (string sname) from-pack)
  496.             (if found
  497.             (shadowing-import sym pack)
  498.             (error "no symbol named ~s in package ~s"
  499.                (string sname)
  500.                from-pack))))))))
  501.      (dolist (opt options)
  502.        (if (eq (first opt) :use)
  503.        (use-package (mapcar #'string (rest opt)) pack)))
  504.      (dolist (opt options)
  505.        (case (first opt)
  506.          (:intern
  507.       (dolist (sname (rest opt)) (intern (string sname) pack)))
  508.      (:import-from
  509.       (let ((from-pack (find-package (second opt))))
  510.         (dolist (sname (rest (rest opt)))
  511.           (multiple-value-bind (sym found)
  512.                    (find-symbol (string sname) from-pack)
  513.             (if found
  514.             (import sym pack)
  515.             (error "no symbol named ~s in package ~s"
  516.                (string sname)
  517.                from-pack))))))))
  518.      (dolist (opt options)
  519.        (if (eq (first opt) :export)
  520.        (dolist (sname (rest opt))
  521.          (export (intern (string sname) pack) pack))))
  522.      pack))
  523.  
  524. #+:packages
  525. (defun apropos2 (s)
  526.        (format t "~&~s" s)
  527.        (when (fboundp s) (format t "  Function"))
  528.        (if (constantp s)
  529.        (format t "  Constant=~s" (symbol-value s))
  530.        (when (boundp s) (format t "  Value=~s" (symbol-value s)))))
  531.        
  532. #+:packages
  533. (defun apropos (x &optional package)
  534.        (if package
  535.        (do-symbols (s package)
  536.                (if (search x (string s) :test #'char-equal)
  537.                (apropos2 s)))
  538.        (do-all-symbols (s)
  539.                (if (search x (string s) :test #'char-equal)
  540.                    (apropos2 s))))
  541.        (values))
  542.  
  543. #+:packages
  544. (defun apropos-list (x &optional package)
  545.        (let ((res nil))
  546.         (if package
  547.         (do-symbols (s package res)
  548.                 (if (search x (string s) :test #'char-equal)
  549.                 (push s res)))
  550.         (do-all-symbols (s res)
  551.                 (if (search x (string s) :test #'char-equal)
  552.                     (push s res))))))
  553.  
  554.  
  555. ;;;;;
  556. ;;;;; Additional Multipla Value Functions and Macros
  557. ;;;;;
  558.  
  559. (export
  560.  '(values-list multiple-value-list multiple-value-bind multiple-value-setq))
  561.  
  562. (defun values-list (x) (apply #'values x))
  563.  
  564. (defmacro multiple-value-list (form)
  565.   `(multiple-value-call #'list ,form))
  566.  
  567. (defmacro multiple-value-bind (vars form &rest body)
  568.   `(multiple-value-call #'(lambda (&optional ,@vars &rest ,(gensym)) ,@body)
  569.             ,form))
  570.  
  571. (defmacro multiple-value-setq (variables form)
  572.   (let* ((tvars (mapcar #'(lambda (x) (gensym "V")) variables))
  573.      (pairs nil))
  574.     (mapc #'(lambda (x y) (push y pairs) (push x pairs)) variables tvars)
  575.     (if (null tvars) (push (gensym) tvars))
  576.     `(multiple-value-bind ,tvars ,form (setq ,@pairs) ,(first tvars))))
  577.  
  578. (push :common *features*)
  579.