lisp.lsp revision 5dfecf96 
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 César 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