Home | History | Annotate | Line # | Download | only in modules 
      1 ;;
      2 ;; Copyright (c) 2001 by The XFree86 Project, Inc.
      3 ;;
      4 ;; Permission is hereby granted, free of charge, to any person obtaining a
      5 ;; copy of this software and associated documentation files (the "Software"),
      6 ;; to deal in the Software without restriction, including without limitation
      7 ;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
      8 ;; and/or sell copies of the Software, and to permit persons to whom the
      9 ;; Software is furnished to do so, subject to the following conditions:
     10 ;;
     11 ;; The above copyright notice and this permission notice shall be included in
     12 ;; all copies or substantial portions of the Software.
     13 ;;
     14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
     15 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
     16 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
     17 ;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     18 ;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
     19 ;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
     20 ;; SOFTWARE.
     21 ;;
     22 ;; Except as contained in this notice, the name of the XFree86 Project shall
     23 ;; not be used in advertising or otherwise to promote the sale, use or other
     24 ;; dealings in this Software without prior written authorization from the
     25 ;; XFree86 Project.
     26 ;;
     27 ;; Author: Paulo Csar Pereira de Andrade
     28 ;;
     29 ;;
     30 ;; $XFree86: xc/programs/xedit/lisp/modules/lisp.lsp,v 1.9 2002/12/04 05:28:01 paulo Exp $
     31 ;;
     32 (provide "lisp")
     33 
     34 (in-package "LISP")
     35 
     36 (export '(
     37     second third fourth fifth sixth seventh eighth ninth tenth
     38     pathname merge-pathnames
     39     logtest signum
     40     alphanumericp copy-seq push pop prog prog*
     41     with-open-file with-output-to-string
     42 ))
     43 
     44 (defun second (a)	(nth 1 a))
     45 (defun third (a)	(nth 2 a))
     46 (defun fourth (a)	(nth 3 a))
     47 (defun fifth (a)	(nth 4 a))
     48 (defun sixth (a)	(nth 5 a))
     49 (defun seventh (a)	(nth 6 a))
     50 (defun eighth (a)	(nth 7 a))
     51 (defun ninth (a)	(nth 8 a))
     52 (defun tenth (a)	(nth 9 a))
     53 
     54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     55 ;; pathnames
     56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     57 (defun pathname (filename)
     58     (values (parse-namestring filename)))
     59 
     60 (defun merge-pathnames (pathname &optional defaults default-version)
     61     (if (null default-version)
     62 	(parse-namestring pathname nil defaults)
     63 	(parse-namestring pathname nil
     64 	    (make-pathname :defaults defaults :version default-version))))
     65 
     66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     67 ;; math
     68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     69 (defun logtest (integer1 integer2)
     70     (not (zerop (logand integer1 integer2))))
     71 
     72 (defun signum (number)
     73     (if (zerop number) number (/ number (abs number))))
     74 
     75 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     76 ;; misc functions/macros
     77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     78 (defun alphanumericp (char)
     79     (or (alpha-char-p char) (not (null (digit-char-p char)))))
     80 
     81 (defun copy-seq (sequence)
     82     (subseq sequence 0))
     83 
     84 (defmacro prog (init &rest body)
     85     `(block nil (let ,init (tagbody ,@body))))
     86 
     87 (defmacro prog* (init &rest body)
     88     `(block nil (let* ,init (tagbody ,@body))))
     89 
     90 (defmacro with-open-file (file &rest body)
     91     `(let ((,(car file) (open ,@(cdr file))))
     92 	(unwind-protect
     93 	    (progn ,@body)
     94 	    (if ,(car file) (close ,(car file))))))
     95 
     96 (defmacro with-output-to-string (stream &rest body)
     97     `(let ((,(car stream) (make-string-output-stream)))
     98 	(unwind-protect
     99 	    (progn ,@body (get-output-stream-string ,(car stream)))
    100 	    (and ,(car stream) (close ,(car stream))))))
    101 
    102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    103 ;; setf
    104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    105 (defsetf car (list) (value)	`(progn (rplaca ,list ,value) ,value))
    106 (defsetf cdr (list) (value)	`(progn (rplacd ,list ,value) ,value))
    107 
    108 (defsetf caar (list) (value)	`(progn (rplaca (car ,list) ,value) ,value))
    109 (defsetf cadr (list) (value)	`(progn (rplaca (cdr ,list) ,value) ,value))
    110 (defsetf cdar (list) (value)	`(progn (rplacd (car ,list) ,value) ,value))
    111 (defsetf cddr (list) (value)	`(progn (rplacd (cdr ,list) ,value) ,value))
    112 (defsetf caaar (list) (value)	`(progn (rplaca (caar ,list) ,value) ,value))
    113 (defsetf caadr (list) (value)	`(progn (rplaca (cadr ,list) ,value) ,value))
    114 (defsetf cadar (list) (value)	`(progn (rplaca (cdar ,list) ,value) ,value))
    115 (defsetf caddr (list) (value)	`(progn (rplaca (cddr ,list) ,value) ,value))
    116 (defsetf cdaar (list) (value)	`(progn (rplacd (caar ,list) ,value) ,value))
    117 (defsetf cdadr (list) (value)	`(progn (rplacd (cadr ,list) ,value) ,value))
    118 (defsetf cddar (list) (value)	`(progn (rplacd (cdar ,list) ,value) ,value))
    119 (defsetf cdddr (list) (value)	`(progn (rplacd (cddr ,list) ,value) ,value))
    120 (defsetf caaaar (list) (value)	`(progn (rplaca (caaar ,list) ,value) ,value))
    121 (defsetf caaadr (list) (value)	`(progn (rplaca (caadr ,list) ,value) ,value))
    122 (defsetf caadar (list) (value)	`(progn (rplaca (cadar ,list) ,value) ,value))
    123 (defsetf caaddr (list) (value)	`(progn (rplaca (caddr ,list) ,value) ,value))
    124 (defsetf cadaar (list) (value)	`(progn (rplaca (cdaar ,list) ,value) ,value))
    125 (defsetf cadadr (list) (value)	`(progn (rplaca (cdadr ,list) ,value) ,value))
    126 (defsetf caddar (list) (value)	`(progn (rplaca (cddar ,list) ,value) ,value))
    127 (defsetf cadddr (list) (value)	`(progn (rplaca (cdddr ,list) ,value) ,value))
    128 (defsetf cdaaar (list) (value)	`(progn (rplacd (caaar ,list) ,value) ,value))
    129 (defsetf cdaadr (list) (value)	`(progn (rplacd (caadr ,list) ,value) ,value))
    130 (defsetf cdadar (list) (value)	`(progn (rplacd (cadar ,list) ,value) ,value))
    131 (defsetf cdaddr (list) (value)	`(progn (rplacd (caddr ,list) ,value) ,value))
    132 (defsetf cddaar (list) (value)	`(progn (rplacd (cdaar ,list) ,value) ,value))
    133 (defsetf cddadr (list) (value)	`(progn (rplacd (cdadr ,list) ,value) ,value))
    134 (defsetf cdddar (list) (value)	`(progn (rplacd (cddar ,list) ,value) ,value))
    135 (defsetf cddddr (list) (value)	`(progn (rplacd (cdddr ,list) ,value) ,value))
    136 
    137 (defsetf first (list) (value)	`(progn (rplaca ,list ,value) ,value))
    138 (defsetf second (list) (value)	`(progn (rplaca (nthcdr 1 ,list) ,value) ,value))
    139 (defsetf third (list) (value)	`(progn (rplaca (nthcdr 2 ,list) ,value) ,value))
    140 (defsetf fourth (list) (value)	`(progn (rplaca (nthcdr 3 ,list) ,value) ,value))
    141 (defsetf fifth (list) (value)	`(progn (rplaca (nthcdr 4 ,list) ,value) ,value))
    142 (defsetf sixth (list) (value)	`(progn (rplaca (nthcdr 5 ,list) ,value) ,value))
    143 (defsetf seventh (list) (value)	`(progn (rplaca (nthcdr 6 ,list) ,value) ,value))
    144 (defsetf eighth (list) (value)	`(progn (rplaca (nthcdr 7 ,list) ,value) ,value))
    145 (defsetf ninth (list) (value)	`(progn (rplaca (nthcdr 8 ,list) ,value) ,value))
    146 (defsetf tenth (list) (value)	`(progn (rplaca (nthcdr 9 ,list) ,value) ,value))
    147 
    148 (defsetf rest (list) (value)	`(progn (rplacd ,list ,value) ,value))
    149 
    150 (defun lisp::nth-store (index list value)
    151     (rplaca (nthcdr index list) value) value)
    152 (defsetf nth lisp::nth-store)
    153 
    154 (defsetf aref (array &rest indices) (value)
    155     `(lisp::vector-store ,array ,@indices ,value))
    156 
    157 (defsetf get (symbol key &optional default) (value)
    158     `(lisp::put ,symbol ,key ,value))
    159 
    160 (defsetf symbol-plist lisp::set-symbol-plist)
    161 
    162 (defsetf gethash (key hash-table &optional default) (value)
    163     `(lisp::puthash ,key ,hash-table ,value))
    164 
    165 (defsetf char lisp::char-store)
    166 (defsetf schar lisp::char-store)
    167 (defsetf elt lisp::elt-store)
    168 (defsetf svref lisp::elt-store)
    169 (defsetf documentation lisp::documentation-store)
    170 
    171 (defsetf symbol-value set)
    172 
    173 (defsetf subseq (sequence start &optional end) (value)
    174     `(progn (replace ,sequence ,value :start1 ,start :end1 ,end) ,value))
    175