Commit | Line | Data |
---|---|---|
ddc9006b | 1 | ;;; Guile Emacs Lisp -*- lexical-binding: t -*- |
6937c7aa BT |
2 | |
3 | ;;; Copyright (C) 2011 Free Software Foundation, Inc. | |
4 | ||
5 | ;;; This library is free software; you can redistribute it and/or modify | |
6 | ;;; it under the terms of the GNU Lesser General Public License as | |
7 | ;;; published by the Free Software Foundation; either version 3 of the | |
8 | ;;; License, or (at your option) any later version. | |
9 | ;;; | |
10 | ;;; This library is distributed in the hope that it will be useful, but | |
11 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;; Lesser General Public License for more details. | |
14 | ;;; | |
15 | ;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;; License along with this library; if not, write to the Free Software | |
17 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
18 | ;;; 02110-1301 USA | |
19 | ||
20 | ;;; Code: | |
9b15703d BT |
21 | |
22 | (defmacro @ (module symbol) | |
23 | `(guile-ref ,module ,symbol)) | |
24 | ||
b652e2b9 BT |
25 | (defmacro eval-and-compile (&rest body) |
26 | `(progn | |
27 | (eval-when-compile ,@body) | |
28 | (progn ,@body))) | |
29 | ||
30 | (eval-and-compile | |
31 | (defun funcall (function &rest arguments) | |
32 | (apply function arguments)) | |
33 | (defun fset (symbol definition) | |
85bc6238 BT |
34 | (funcall (@ (language elisp runtime) set-symbol-function!) |
35 | symbol | |
36 | definition)) | |
b652e2b9 BT |
37 | (defun null (object) |
38 | (if object nil t)) | |
39 | (fset 'consp (@ (guile) pair?)) | |
40 | (defun listp (object) | |
41 | (if object (consp object) t)) | |
42 | (defun car (list) | |
43 | (if list (funcall (@ (guile) car) list) nil)) | |
44 | (defun cdr (list) | |
45 | (if list (funcall (@ (guile) cdr) list) nil)) | |
46 | (fset 'make-symbol (@ (guile) make-symbol)) | |
47 | (defun signal (&rest args) | |
48 | (funcall (@ (guile) throw) 'elisp-error args))) | |
49 | ||
50 | (defmacro lambda (&rest cdr) | |
51 | `#'(lambda ,@cdr)) | |
52 | ||
53 | (defmacro prog1 (first &rest body) | |
54 | (let ((temp (make-symbol "prog1-temp"))) | |
55 | `(lexical-let ((,temp ,first)) | |
56 | ,@body | |
57 | ,temp))) | |
58 | ||
59 | (defmacro prog2 (form1 form2 &rest body) | |
60 | `(progn ,form1 (prog1 ,form2 ,@body))) | |
61 | ||
62 | (defmacro cond (&rest clauses) | |
63 | (if (null clauses) | |
64 | nil | |
65 | (let ((first (car clauses)) | |
66 | (rest (cdr clauses))) | |
67 | (if (listp first) | |
68 | (let ((condition (car first)) | |
69 | (body (cdr first))) | |
70 | (if (null body) | |
71 | (let ((temp (make-symbol "cond-temp"))) | |
72 | `(lexical-let ((,temp ,condition)) | |
73 | (if ,temp | |
74 | ,temp | |
75 | (cond ,@rest)))) | |
76 | `(if ,condition | |
77 | (progn ,@body) | |
78 | (cond ,@rest)))) | |
79 | (signal 'wrong-type-argument `(listp ,first)))))) | |
80 | ||
81 | (defmacro and (&rest conditions) | |
82 | (cond ((null conditions) t) | |
83 | ((null (cdr conditions)) (car conditions)) | |
84 | (t `(if ,(car conditions) | |
85 | (and ,@(cdr conditions)) | |
86 | nil)))) | |
87 | ||
88 | (defmacro or (&rest conditions) | |
89 | (cond ((null conditions) nil) | |
90 | ((null (cdr conditions)) (car conditions)) | |
91 | (t (let ((temp (make-symbol "or-temp"))) | |
92 | `(lexical-let ((,temp ,(car conditions))) | |
93 | (if ,temp | |
94 | ,temp | |
95 | (or ,@(cdr conditions)))))))) | |
96 | ||
97 | (defmacro catch (tag &rest body) | |
98 | (let* ((temp (make-symbol "catch-temp")) | |
99 | (elisp-key (make-symbol "catch-elisp-key")) | |
5fa5bf7d | 100 | (key (make-symbol "catch-key")) |
b652e2b9 BT |
101 | (value (make-symbol "catch-value"))) |
102 | `(lexical-let ((,temp ,tag)) | |
103 | (funcall (@ (guile) catch) | |
5fa5bf7d | 104 | 'elisp-exception |
b652e2b9 | 105 | #'(lambda () ,@body) |
5fa5bf7d | 106 | #'(lambda (,key ,elisp-key ,value) |
b652e2b9 BT |
107 | (if (eq ,elisp-key ,temp) |
108 | ,value | |
109 | (funcall (@ (guile) throw) | |
5fa5bf7d | 110 | ,key |
b652e2b9 BT |
111 | ,elisp-key |
112 | ,value))))))) | |
113 | ||
114 | (defmacro unwind-protect (bodyform &rest unwindforms) | |
115 | `(funcall (@ (guile) dynamic-wind) | |
116 | #'(lambda () nil) | |
117 | #'(lambda () ,bodyform) | |
118 | #'(lambda () ,@unwindforms))) | |
9b15703d | 119 | |
97d9da9a BT |
120 | (defun throw (tag value) |
121 | (funcall (@ (guile) throw) 'elisp-exception tag value)) | |
122 | ||
5bcc6d9e BT |
123 | (defun eval (form) |
124 | (funcall (@ (system base compile) compile) | |
125 | form | |
126 | (funcall (@ (guile) symbol->keyword) 'from) | |
127 | 'elisp | |
128 | (funcall (@ (guile) symbol->keyword) 'to) | |
129 | 'value)) | |
130 | ||
131 | (defun load (file) | |
132 | (funcall (@ (system base compile) compile-file) | |
133 | file | |
134 | (funcall (@ (guile) symbol->keyword) 'from) | |
135 | 'elisp | |
136 | (funcall (@ (guile) symbol->keyword) 'to) | |
137 | 'value) | |
138 | t) | |
139 | ||
9b15703d BT |
140 | ;;; Equality predicates |
141 | ||
142 | (fset 'eq (@ (guile) eq?)) | |
143 | (fset 'equal (@ (guile) equal?)) | |
144 | ||
85bc6238 BT |
145 | ;;; Symbols |
146 | ||
147 | (fset 'symbolp (@ (guile) symbol?)) | |
148 | (fset 'symbol-value (@ (language elisp runtime) symbol-value)) | |
149 | (fset 'symbol-function (@ (language elisp runtime) symbol-function)) | |
150 | (fset 'set (@ (language elisp runtime) set-symbol-value!)) | |
151 | (fset 'makunbound (@ (language elisp runtime) makunbound!)) | |
152 | (fset 'fmakunbound (@ (language elisp runtime) fmakunbound!)) | |
153 | (fset 'boundp (@ (language elisp runtime) symbol-bound?)) | |
154 | (fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) | |
155 | ||
14b288ce BT |
156 | (defun defvaralias (new-alias base-variable &optional docstring) |
157 | (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) | |
158 | base-variable))) | |
159 | (funcall (@ (language elisp runtime) set-symbol-fluid!) | |
160 | new-alias | |
161 | fluid) | |
162 | base-variable)) | |
163 | ||
9b15703d BT |
164 | ;;; Numerical type predicates |
165 | ||
166 | (defun floatp (object) | |
167 | (and (funcall (@ (guile) real?) object) | |
168 | (or (funcall (@ (guile) inexact?) object) | |
169 | (null (funcall (@ (guile) integer?) object))))) | |
170 | ||
171 | (defun integerp (object) | |
172 | (and (funcall (@ (guile) exact?) object) | |
173 | (funcall (@ (guile) integer?) object))) | |
174 | ||
175 | (defun numberp (object) | |
176 | (funcall (@ (guile) real?) object)) | |
177 | ||
178 | (defun wholenump (object) | |
179 | (and (funcall (@ (guile) exact?) object) | |
180 | (funcall (@ (guile) integer?) object) | |
181 | (>= object 0))) | |
182 | ||
183 | (defun zerop (object) | |
184 | (= object 0)) | |
185 | ||
186 | ;;; Numerical comparisons | |
187 | ||
188 | (fset '= (@ (guile) =)) | |
189 | ||
190 | (defun /= (num1 num2) | |
191 | (null (= num1 num2))) | |
192 | ||
193 | (fset '< (@ (guile) <)) | |
194 | (fset '<= (@ (guile) <=)) | |
195 | (fset '> (@ (guile) >)) | |
196 | (fset '>= (@ (guile) >=)) | |
197 | ||
198 | (defun max (&rest numbers) | |
199 | (apply (@ (guile) max) numbers)) | |
200 | ||
201 | (defun min (&rest numbers) | |
202 | (apply (@ (guile) min) numbers)) | |
203 | ||
204 | ;;; Arithmetic functions | |
205 | ||
206 | (fset '1+ (@ (guile) 1+)) | |
207 | (fset '1- (@ (guile) 1-)) | |
208 | (fset '+ (@ (guile) +)) | |
209 | (fset '- (@ (guile) -)) | |
210 | (fset '* (@ (guile) *)) | |
211 | (fset '% (@ (guile) modulo)) | |
212 | (fset 'abs (@ (guile) abs)) | |
213 | ||
214 | ;;; Floating-point rounding | |
215 | ||
216 | (fset 'ffloor (@ (guile) floor)) | |
217 | (fset 'fceiling (@ (guile) ceiling)) | |
218 | (fset 'ftruncate (@ (guile) truncate)) | |
219 | (fset 'fround (@ (guile) round)) | |
220 | ||
221 | ;;; Numeric conversion | |
222 | ||
223 | (defun float (arg) | |
224 | (if (numberp arg) | |
225 | (funcall (@ (guile) exact->inexact) arg) | |
226 | (signal 'wrong-type-argument `(numberp ,arg)))) | |
227 | ||
228 | ;;; List predicates | |
229 | ||
9b15703d BT |
230 | (fset 'not #'null) |
231 | ||
232 | (defun atom (object) | |
233 | (null (consp object))) | |
234 | ||
9b15703d BT |
235 | (defun nlistp (object) |
236 | (null (listp object))) | |
237 | ||
238 | ;;; Lists | |
239 | ||
240 | (fset 'cons (@ (guile) cons)) | |
241 | (fset 'list (@ (guile) list)) | |
242 | (fset 'make-list (@ (guile) make-list)) | |
243 | (fset 'append (@ (guile) append)) | |
244 | (fset 'reverse (@ (guile) reverse)) | |
245 | ||
9b15703d BT |
246 | (defun car-safe (object) |
247 | (if (consp object) | |
248 | (car object) | |
249 | nil)) | |
250 | ||
251 | (defun cdr-safe (object) | |
252 | (if (consp object) | |
253 | (cdr object) | |
254 | nil)) | |
255 | ||
256 | (defun setcar (cell newcar) | |
257 | (if (consp cell) | |
258 | (progn | |
259 | (funcall (@ (guile) set-car!) cell newcar) | |
260 | newcar) | |
261 | (signal 'wrong-type-argument `(consp ,cell)))) | |
262 | ||
263 | (defun setcdr (cell newcdr) | |
264 | (if (consp cell) | |
265 | (progn | |
266 | (funcall (@ (guile) set-cdr!) cell newcdr) | |
267 | newcdr) | |
268 | (signal 'wrong-type-argument `(consp ,cell)))) | |
269 | ||
270 | (defun nthcdr (n list) | |
271 | (let ((i 0)) | |
272 | (while (< i n) | |
273 | (setq list (cdr list) | |
274 | i (+ i 1))) | |
275 | list)) | |
276 | ||
277 | (defun nth (n list) | |
278 | (car (nthcdr n list))) | |
279 | ||
8f2f6566 BT |
280 | ;;; Strings |
281 | ||
282 | (defun string (&rest characters) | |
283 | (funcall (@ (guile) list->string) | |
284 | (mapcar (@ (guile) integer->char) characters))) | |
285 | ||
9b15703d BT |
286 | ;;; Sequences |
287 | ||
288 | (fset 'length (@ (guile) length)) | |
8f2f6566 BT |
289 | |
290 | (defun mapcar (function sequence) | |
291 | (funcall (@ (guile) map) function sequence)) | |
12ca82ca BT |
292 | |
293 | ;;; Property lists | |
294 | ||
295 | (defun %plist-member (plist property test) | |
296 | (catch 'loop | |
297 | (while plist | |
298 | (if (funcall test (car plist) property) | |
299 | (throw 'loop (cdr plist)) | |
300 | (setq plist (cddr plist)))))) | |
301 | ||
302 | (defun %plist-get (plist property test) | |
303 | (car (%plist-member plist property test))) | |
304 | ||
305 | (defun %plist-put (plist property value test) | |
306 | (lexical-let ((x (%plist-member plist property test))) | |
307 | (if x | |
308 | (progn (setcar x value) plist) | |
309 | (cons property (cons value plist))))) | |
310 | ||
311 | (defun plist-get (plist property) | |
312 | (%plist-get plist property #'eq)) | |
313 | ||
314 | (defun plist-put (plist property value) | |
315 | (%plist-put plist property value #'eq)) | |
316 | ||
317 | (defun plist-member (plist property) | |
318 | (%plist-member plist property #'eq)) | |
319 | ||
320 | (defun lax-plist-get (plist property) | |
321 | (%plist-get plist property #'equal)) | |
322 | ||
323 | (defun lax-plist-put (plist property value) | |
324 | (%plist-put plist property value #'equal)) | |
325 | ||
326 | (defvar plist-function (funcall (@ (guile) make-object-property))) | |
327 | ||
328 | (defun symbol-plist (symbol) | |
329 | (funcall plist-function symbol)) | |
330 | ||
331 | (defun setplist (symbol plist) | |
332 | (funcall (funcall (@ (guile) setter) plist-function) symbol plist)) | |
333 | ||
334 | (defun get (symbol propname) | |
335 | (plist-get (symbol-plist symbol) propname)) | |
336 | ||
337 | (defun put (symbol propname value) | |
338 | (setplist symbol (plist-put (symbol-plist symbol) propname value))) |