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 | |
b652e2b9 BT |
31 | (defun null (object) |
32 | (if object nil t)) | |
b05ca4ab BT |
33 | (defun consp (object) |
34 | (%funcall (@ (guile) pair?) object)) | |
b652e2b9 BT |
35 | (defun listp (object) |
36 | (if object (consp object) t)) | |
37 | (defun car (list) | |
b05ca4ab | 38 | (if list (%funcall (@ (guile) car) list) nil)) |
b652e2b9 | 39 | (defun cdr (list) |
b05ca4ab BT |
40 | (if list (%funcall (@ (guile) cdr) list) nil)) |
41 | (defun make-symbol (name) | |
42 | (%funcall (@ (guile) make-symbol) name)) | |
b652e2b9 | 43 | (defun signal (&rest args) |
b05ca4ab | 44 | (%funcall (@ (guile) throw) 'elisp-error args))) |
b652e2b9 BT |
45 | |
46 | (defmacro lambda (&rest cdr) | |
47 | `#'(lambda ,@cdr)) | |
48 | ||
49 | (defmacro prog1 (first &rest body) | |
50 | (let ((temp (make-symbol "prog1-temp"))) | |
51 | `(lexical-let ((,temp ,first)) | |
52 | ,@body | |
53 | ,temp))) | |
54 | ||
55 | (defmacro prog2 (form1 form2 &rest body) | |
56 | `(progn ,form1 (prog1 ,form2 ,@body))) | |
57 | ||
58 | (defmacro cond (&rest clauses) | |
59 | (if (null clauses) | |
60 | nil | |
61 | (let ((first (car clauses)) | |
62 | (rest (cdr clauses))) | |
63 | (if (listp first) | |
64 | (let ((condition (car first)) | |
65 | (body (cdr first))) | |
66 | (if (null body) | |
67 | (let ((temp (make-symbol "cond-temp"))) | |
68 | `(lexical-let ((,temp ,condition)) | |
69 | (if ,temp | |
70 | ,temp | |
71 | (cond ,@rest)))) | |
72 | `(if ,condition | |
73 | (progn ,@body) | |
74 | (cond ,@rest)))) | |
75 | (signal 'wrong-type-argument `(listp ,first)))))) | |
76 | ||
77 | (defmacro and (&rest conditions) | |
78 | (cond ((null conditions) t) | |
79 | ((null (cdr conditions)) (car conditions)) | |
80 | (t `(if ,(car conditions) | |
81 | (and ,@(cdr conditions)) | |
82 | nil)))) | |
83 | ||
84 | (defmacro or (&rest conditions) | |
85 | (cond ((null conditions) nil) | |
86 | ((null (cdr conditions)) (car conditions)) | |
87 | (t (let ((temp (make-symbol "or-temp"))) | |
88 | `(lexical-let ((,temp ,(car conditions))) | |
89 | (if ,temp | |
90 | ,temp | |
91 | (or ,@(cdr conditions)))))))) | |
92 | ||
93 | (defmacro catch (tag &rest body) | |
94 | (let* ((temp (make-symbol "catch-temp")) | |
95 | (elisp-key (make-symbol "catch-elisp-key")) | |
5fa5bf7d | 96 | (key (make-symbol "catch-key")) |
b652e2b9 BT |
97 | (value (make-symbol "catch-value"))) |
98 | `(lexical-let ((,temp ,tag)) | |
99 | (funcall (@ (guile) catch) | |
5fa5bf7d | 100 | 'elisp-exception |
b652e2b9 | 101 | #'(lambda () ,@body) |
5fa5bf7d | 102 | #'(lambda (,key ,elisp-key ,value) |
b652e2b9 BT |
103 | (if (eq ,elisp-key ,temp) |
104 | ,value | |
105 | (funcall (@ (guile) throw) | |
5fa5bf7d | 106 | ,key |
b652e2b9 BT |
107 | ,elisp-key |
108 | ,value))))))) | |
109 | ||
110 | (defmacro unwind-protect (bodyform &rest unwindforms) | |
111 | `(funcall (@ (guile) dynamic-wind) | |
112 | #'(lambda () nil) | |
113 | #'(lambda () ,bodyform) | |
114 | #'(lambda () ,@unwindforms))) | |
9b15703d | 115 | |
b05ca4ab BT |
116 | (defun symbolp (object) |
117 | (%funcall (@ (guile) symbol?) object)) | |
118 | ||
119 | (defun functionp (object) | |
120 | (%funcall (@ (guile) procedure?) object)) | |
121 | ||
122 | (defun symbol-function (symbol) | |
123 | (let ((f (%funcall (@ (language elisp runtime) symbol-function) | |
124 | symbol))) | |
125 | (if (%funcall (@ (language elisp falias) falias?) f) | |
126 | (%funcall (@ (language elisp falias) falias-object) f) | |
127 | f))) | |
97d9da9a | 128 | |
5bcc6d9e | 129 | (defun eval (form) |
b05ca4ab BT |
130 | (%funcall (@ (system base compile) compile) |
131 | form | |
132 | (%funcall (@ (guile) symbol->keyword) 'from) | |
133 | 'elisp | |
134 | (%funcall (@ (guile) symbol->keyword) 'to) | |
135 | 'value)) | |
136 | ||
137 | (defun %indirect-function (object) | |
138 | (cond | |
139 | ((functionp object) | |
140 | object) | |
141 | ((symbolp object) ;++ cycle detection | |
142 | (%indirect-function (symbol-function object))) | |
143 | ((listp object) | |
144 | (eval `(function ,object))) | |
145 | (t | |
146 | (signal 'invalid-function `(,object))))) | |
147 | ||
148 | (defun apply (function &rest arguments) | |
149 | (%funcall (@ (guile) apply) | |
150 | (@ (guile) apply) | |
151 | (%indirect-function function) | |
152 | arguments)) | |
153 | ||
154 | (defun funcall (function &rest arguments) | |
155 | (%funcall (@ (guile) apply) | |
156 | (%indirect-function function) | |
157 | arguments)) | |
158 | ||
159 | (defun fset (symbol definition) | |
160 | (funcall (@ (language elisp runtime) set-symbol-function!) | |
161 | symbol | |
162 | (if (functionp definition) | |
163 | definition | |
164 | (funcall (@ (language elisp falias) make-falias) | |
165 | #'(lambda (&rest args) (apply definition args)) | |
166 | definition))) | |
167 | definition) | |
168 | ||
169 | (defun throw (tag value) | |
170 | (funcall (@ (guile) throw) 'elisp-exception tag value)) | |
5bcc6d9e BT |
171 | |
172 | (defun load (file) | |
173 | (funcall (@ (system base compile) compile-file) | |
174 | file | |
175 | (funcall (@ (guile) symbol->keyword) 'from) | |
176 | 'elisp | |
177 | (funcall (@ (guile) symbol->keyword) 'to) | |
178 | 'value) | |
179 | t) | |
180 | ||
9b15703d BT |
181 | ;;; Equality predicates |
182 | ||
0ab2a63a BT |
183 | (defun eq (obj1 obj2) |
184 | (if obj1 | |
185 | (funcall (@ (guile) eq?) obj1 obj2) | |
186 | (null obj2))) | |
187 | ||
188 | (defun eql (obj1 obj2) | |
189 | (if obj1 | |
190 | (funcall (@ (guile) eqv?) obj1 obj2) | |
191 | (null obj2))) | |
192 | ||
193 | (defun equal (obj1 obj2) | |
194 | (if obj1 | |
195 | (funcall (@ (guile) equal?) obj1 obj2) | |
196 | (null obj2))) | |
9b15703d | 197 | |
85bc6238 BT |
198 | ;;; Symbols |
199 | ||
b05ca4ab BT |
200 | ;;; `symbolp' and `symbol-function' are defined above. |
201 | ||
85bc6238 | 202 | (fset 'symbol-value (@ (language elisp runtime) symbol-value)) |
85bc6238 BT |
203 | (fset 'set (@ (language elisp runtime) set-symbol-value!)) |
204 | (fset 'makunbound (@ (language elisp runtime) makunbound!)) | |
205 | (fset 'fmakunbound (@ (language elisp runtime) fmakunbound!)) | |
206 | (fset 'boundp (@ (language elisp runtime) symbol-bound?)) | |
207 | (fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) | |
208 | ||
14b288ce BT |
209 | (defun defvaralias (new-alias base-variable &optional docstring) |
210 | (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) | |
211 | base-variable))) | |
212 | (funcall (@ (language elisp runtime) set-symbol-fluid!) | |
213 | new-alias | |
214 | fluid) | |
215 | base-variable)) | |
216 | ||
9b15703d BT |
217 | ;;; Numerical type predicates |
218 | ||
219 | (defun floatp (object) | |
220 | (and (funcall (@ (guile) real?) object) | |
221 | (or (funcall (@ (guile) inexact?) object) | |
222 | (null (funcall (@ (guile) integer?) object))))) | |
223 | ||
224 | (defun integerp (object) | |
225 | (and (funcall (@ (guile) exact?) object) | |
226 | (funcall (@ (guile) integer?) object))) | |
227 | ||
228 | (defun numberp (object) | |
229 | (funcall (@ (guile) real?) object)) | |
230 | ||
231 | (defun wholenump (object) | |
232 | (and (funcall (@ (guile) exact?) object) | |
233 | (funcall (@ (guile) integer?) object) | |
234 | (>= object 0))) | |
235 | ||
236 | (defun zerop (object) | |
237 | (= object 0)) | |
238 | ||
239 | ;;; Numerical comparisons | |
240 | ||
241 | (fset '= (@ (guile) =)) | |
242 | ||
243 | (defun /= (num1 num2) | |
244 | (null (= num1 num2))) | |
245 | ||
246 | (fset '< (@ (guile) <)) | |
247 | (fset '<= (@ (guile) <=)) | |
248 | (fset '> (@ (guile) >)) | |
249 | (fset '>= (@ (guile) >=)) | |
250 | ||
251 | (defun max (&rest numbers) | |
252 | (apply (@ (guile) max) numbers)) | |
253 | ||
254 | (defun min (&rest numbers) | |
255 | (apply (@ (guile) min) numbers)) | |
256 | ||
257 | ;;; Arithmetic functions | |
258 | ||
259 | (fset '1+ (@ (guile) 1+)) | |
260 | (fset '1- (@ (guile) 1-)) | |
261 | (fset '+ (@ (guile) +)) | |
262 | (fset '- (@ (guile) -)) | |
263 | (fset '* (@ (guile) *)) | |
264 | (fset '% (@ (guile) modulo)) | |
265 | (fset 'abs (@ (guile) abs)) | |
266 | ||
267 | ;;; Floating-point rounding | |
268 | ||
269 | (fset 'ffloor (@ (guile) floor)) | |
270 | (fset 'fceiling (@ (guile) ceiling)) | |
271 | (fset 'ftruncate (@ (guile) truncate)) | |
272 | (fset 'fround (@ (guile) round)) | |
273 | ||
274 | ;;; Numeric conversion | |
275 | ||
276 | (defun float (arg) | |
277 | (if (numberp arg) | |
278 | (funcall (@ (guile) exact->inexact) arg) | |
279 | (signal 'wrong-type-argument `(numberp ,arg)))) | |
280 | ||
281 | ;;; List predicates | |
282 | ||
9b15703d BT |
283 | (fset 'not #'null) |
284 | ||
285 | (defun atom (object) | |
286 | (null (consp object))) | |
287 | ||
9b15703d BT |
288 | (defun nlistp (object) |
289 | (null (listp object))) | |
290 | ||
291 | ;;; Lists | |
292 | ||
293 | (fset 'cons (@ (guile) cons)) | |
294 | (fset 'list (@ (guile) list)) | |
295 | (fset 'make-list (@ (guile) make-list)) | |
296 | (fset 'append (@ (guile) append)) | |
297 | (fset 'reverse (@ (guile) reverse)) | |
298 | ||
9b15703d BT |
299 | (defun car-safe (object) |
300 | (if (consp object) | |
301 | (car object) | |
302 | nil)) | |
303 | ||
304 | (defun cdr-safe (object) | |
305 | (if (consp object) | |
306 | (cdr object) | |
307 | nil)) | |
308 | ||
309 | (defun setcar (cell newcar) | |
310 | (if (consp cell) | |
311 | (progn | |
312 | (funcall (@ (guile) set-car!) cell newcar) | |
313 | newcar) | |
314 | (signal 'wrong-type-argument `(consp ,cell)))) | |
315 | ||
316 | (defun setcdr (cell newcdr) | |
317 | (if (consp cell) | |
318 | (progn | |
319 | (funcall (@ (guile) set-cdr!) cell newcdr) | |
320 | newcdr) | |
321 | (signal 'wrong-type-argument `(consp ,cell)))) | |
322 | ||
323 | (defun nthcdr (n list) | |
324 | (let ((i 0)) | |
325 | (while (< i n) | |
326 | (setq list (cdr list) | |
327 | i (+ i 1))) | |
328 | list)) | |
329 | ||
330 | (defun nth (n list) | |
331 | (car (nthcdr n list))) | |
332 | ||
8f2f6566 BT |
333 | ;;; Strings |
334 | ||
335 | (defun string (&rest characters) | |
336 | (funcall (@ (guile) list->string) | |
337 | (mapcar (@ (guile) integer->char) characters))) | |
338 | ||
9b15703d BT |
339 | ;;; Sequences |
340 | ||
341 | (fset 'length (@ (guile) length)) | |
8f2f6566 BT |
342 | |
343 | (defun mapcar (function sequence) | |
344 | (funcall (@ (guile) map) function sequence)) | |
12ca82ca BT |
345 | |
346 | ;;; Property lists | |
347 | ||
348 | (defun %plist-member (plist property test) | |
349 | (catch 'loop | |
350 | (while plist | |
351 | (if (funcall test (car plist) property) | |
352 | (throw 'loop (cdr plist)) | |
353 | (setq plist (cddr plist)))))) | |
354 | ||
355 | (defun %plist-get (plist property test) | |
356 | (car (%plist-member plist property test))) | |
357 | ||
358 | (defun %plist-put (plist property value test) | |
359 | (lexical-let ((x (%plist-member plist property test))) | |
360 | (if x | |
361 | (progn (setcar x value) plist) | |
362 | (cons property (cons value plist))))) | |
363 | ||
364 | (defun plist-get (plist property) | |
365 | (%plist-get plist property #'eq)) | |
366 | ||
367 | (defun plist-put (plist property value) | |
368 | (%plist-put plist property value #'eq)) | |
369 | ||
370 | (defun plist-member (plist property) | |
371 | (%plist-member plist property #'eq)) | |
372 | ||
373 | (defun lax-plist-get (plist property) | |
374 | (%plist-get plist property #'equal)) | |
375 | ||
376 | (defun lax-plist-put (plist property value) | |
377 | (%plist-put plist property value #'equal)) | |
378 | ||
379 | (defvar plist-function (funcall (@ (guile) make-object-property))) | |
380 | ||
381 | (defun symbol-plist (symbol) | |
382 | (funcall plist-function symbol)) | |
383 | ||
384 | (defun setplist (symbol plist) | |
385 | (funcall (funcall (@ (guile) setter) plist-function) symbol plist)) | |
386 | ||
387 | (defun get (symbol propname) | |
388 | (plist-get (symbol-plist symbol) propname)) | |
389 | ||
390 | (defun put (symbol propname value) | |
391 | (setplist symbol (plist-put (symbol-plist symbol) propname value))) |