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 | ||
0b04d826 RT |
25 | (defmacro @@ (module symbol) |
26 | `(guile-private-ref ,module ,symbol)) | |
27 | ||
0faf3965 RT |
28 | (defmacro defun (name args &rest body) |
29 | `(let ((proc (function (lambda ,args ,@body)))) | |
30 | (%funcall (@ (language elisp runtime) set-symbol-function!) | |
31 | ',name | |
32 | proc) | |
33 | (%funcall (@ (guile) set-procedure-property!) | |
34 | proc 'name ',name) | |
35 | ',name)) | |
36 | ||
37 | (defun omega () (omega)) | |
38 | ||
b652e2b9 BT |
39 | (defmacro eval-and-compile (&rest body) |
40 | `(progn | |
41 | (eval-when-compile ,@body) | |
42 | (progn ,@body))) | |
43 | ||
cb2ccc5c RT |
44 | (defmacro %define-compiler-macro (name args &rest body) |
45 | `(eval-and-compile | |
46 | (%funcall | |
47 | (@ (language elisp runtime) set-symbol-plist!) | |
48 | ',name | |
49 | (%funcall | |
50 | (@ (guile) cons*) | |
51 | '%compiler-macro | |
52 | #'(lambda ,args ,@body) | |
53 | (%funcall (@ (language elisp runtime) symbol-plist) ',name))) | |
54 | ',name)) | |
55 | ||
b473eddf RT |
56 | (defmacro defsubst (name args &rest body) |
57 | `(progn | |
58 | (defun ,name ,args ,@body) | |
59 | (eval-and-compile | |
60 | (%define-compiler-macro ,name (form) | |
61 | (%funcall (@ (guile) cons*) | |
62 | '%funcall | |
63 | (%funcall | |
64 | (@ (guile) list) | |
65 | 'function | |
66 | (%funcall (@ (guile) cons*) 'lambda ',args ',body)) | |
67 | (%funcall (@ (guile) cdr) form)))))) | |
68 | ||
0faf3965 RT |
69 | (eval-and-compile |
70 | (defun eval (form) | |
71 | (%funcall (@ (language elisp runtime) eval-elisp) form))) | |
72 | ||
b652e2b9 | 73 | (eval-and-compile |
f532ae96 RT |
74 | (defsubst null (object) |
75 | (declare (lexical object)) | |
b652e2b9 | 76 | (if object nil t)) |
f532ae96 RT |
77 | (defsubst consp (x) |
78 | (declare (lexical x)) | |
79 | (%funcall (@ (guile) pair?) x)) | |
80 | (defsubst atom (x) | |
81 | (declare (lexical x)) | |
82 | (null (consp x))) | |
b652e2b9 | 83 | (defun listp (object) |
f532ae96 | 84 | (declare (lexical object)) |
b652e2b9 | 85 | (if object (consp object) t)) |
f532ae96 RT |
86 | (defsubst car (list) |
87 | (declare (lexical list)) | |
b05ca4ab | 88 | (if list (%funcall (@ (guile) car) list) nil)) |
f532ae96 RT |
89 | (defsubst cdr (list) |
90 | (declare (lexical list)) | |
b05ca4ab BT |
91 | (if list (%funcall (@ (guile) cdr) list) nil)) |
92 | (defun make-symbol (name) | |
93 | (%funcall (@ (guile) make-symbol) name)) | |
0faf3965 RT |
94 | (defun gensym () |
95 | (%funcall (@ (guile) gensym))) | |
5950f674 BT |
96 | (defun signal (error-symbol data) |
97 | (%funcall (@ (guile) throw) 'elisp-condition error-symbol data))) | |
b652e2b9 BT |
98 | |
99 | (defmacro lambda (&rest cdr) | |
100 | `#'(lambda ,@cdr)) | |
101 | ||
102 | (defmacro prog1 (first &rest body) | |
0faf3965 | 103 | (let ((temp (gensym))) |
13f022c9 BT |
104 | `(let ((,temp ,first)) |
105 | (declare (lexical ,temp)) | |
b652e2b9 BT |
106 | ,@body |
107 | ,temp))) | |
108 | ||
0faf3965 RT |
109 | (defun interactive (&optional arg) |
110 | nil) | |
111 | ||
b652e2b9 BT |
112 | (defmacro prog2 (form1 form2 &rest body) |
113 | `(progn ,form1 (prog1 ,form2 ,@body))) | |
114 | ||
115 | (defmacro cond (&rest clauses) | |
116 | (if (null clauses) | |
117 | nil | |
118 | (let ((first (car clauses)) | |
119 | (rest (cdr clauses))) | |
120 | (if (listp first) | |
121 | (let ((condition (car first)) | |
122 | (body (cdr first))) | |
123 | (if (null body) | |
0faf3965 | 124 | (let ((temp (gensym))) |
13f022c9 BT |
125 | `(let ((,temp ,condition)) |
126 | (declare (lexical ,temp)) | |
b652e2b9 BT |
127 | (if ,temp |
128 | ,temp | |
129 | (cond ,@rest)))) | |
130 | `(if ,condition | |
131 | (progn ,@body) | |
132 | (cond ,@rest)))) | |
133 | (signal 'wrong-type-argument `(listp ,first)))))) | |
134 | ||
135 | (defmacro and (&rest conditions) | |
136 | (cond ((null conditions) t) | |
137 | ((null (cdr conditions)) (car conditions)) | |
138 | (t `(if ,(car conditions) | |
139 | (and ,@(cdr conditions)) | |
140 | nil)))) | |
141 | ||
142 | (defmacro or (&rest conditions) | |
143 | (cond ((null conditions) nil) | |
144 | ((null (cdr conditions)) (car conditions)) | |
0faf3965 | 145 | (t (let ((temp (gensym))) |
13f022c9 BT |
146 | `(let ((,temp ,(car conditions))) |
147 | (declare (lexical ,temp)) | |
b652e2b9 BT |
148 | (if ,temp |
149 | ,temp | |
150 | (or ,@(cdr conditions)))))))) | |
151 | ||
9083c48d BT |
152 | (defmacro lexical-let (bindings &rest body) |
153 | (labels ((loop (list vars) | |
154 | (if (null list) | |
155 | `(let ,bindings | |
156 | (declare (lexical ,@vars)) | |
157 | ,@body) | |
158 | (loop (cdr list) | |
159 | (if (consp (car list)) | |
160 | `(,(car (car list)) ,@vars) | |
161 | `(,(car list) ,@vars)))))) | |
162 | (loop bindings '()))) | |
163 | ||
164 | (defmacro lexical-let* (bindings &rest body) | |
165 | (labels ((loop (list vars) | |
166 | (if (null list) | |
167 | `(let* ,bindings | |
168 | (declare (lexical ,@vars)) | |
169 | ,@body) | |
170 | (loop (cdr list) | |
171 | (if (consp (car list)) | |
172 | (cons (car (car list)) vars) | |
173 | (cons (car list) vars)))))) | |
174 | (loop bindings '()))) | |
175 | ||
9b90b453 | 176 | (defmacro while (test &rest body) |
0faf3965 | 177 | (let ((loop (gensym))) |
9b90b453 BT |
178 | `(labels ((,loop () |
179 | (if ,test | |
180 | (progn ,@body (,loop)) | |
181 | nil))) | |
182 | (,loop)))) | |
183 | ||
b652e2b9 | 184 | (defmacro unwind-protect (bodyform &rest unwindforms) |
0faf3965 RT |
185 | `(%funcall (@ (guile) dynamic-wind) |
186 | #'(lambda () nil) | |
187 | #'(lambda () ,bodyform) | |
188 | #'(lambda () ,@unwindforms))) | |
9b15703d | 189 | |
c0652730 BT |
190 | (defmacro when (cond &rest body) |
191 | `(if ,cond | |
192 | (progn ,@body))) | |
193 | ||
194 | (defmacro unless (cond &rest body) | |
195 | `(when (not ,cond) | |
196 | ,@body)) | |
197 | ||
b05ca4ab BT |
198 | (defun symbolp (object) |
199 | (%funcall (@ (guile) symbol?) object)) | |
200 | ||
0faf3965 | 201 | (defun %functionp (object) |
b05ca4ab BT |
202 | (%funcall (@ (guile) procedure?) object)) |
203 | ||
204 | (defun symbol-function (symbol) | |
205 | (let ((f (%funcall (@ (language elisp runtime) symbol-function) | |
206 | symbol))) | |
207 | (if (%funcall (@ (language elisp falias) falias?) f) | |
208 | (%funcall (@ (language elisp falias) falias-object) f) | |
209 | f))) | |
97d9da9a | 210 | |
5bcc6d9e | 211 | (defun eval (form) |
3f577464 | 212 | (%funcall (@ (language elisp runtime) eval-elisp) form)) |
b05ca4ab BT |
213 | |
214 | (defun %indirect-function (object) | |
215 | (cond | |
0faf3965 | 216 | ((%functionp object) |
b05ca4ab | 217 | object) |
0faf3965 RT |
218 | ((null object) |
219 | (signal 'void-function nil)) | |
b05ca4ab | 220 | ((symbolp object) ;++ cycle detection |
0faf3965 RT |
221 | (%indirect-function |
222 | (%funcall (@ (language elisp runtime) symbol-function) object))) | |
b05ca4ab BT |
223 | ((listp object) |
224 | (eval `(function ,object))) | |
225 | (t | |
226 | (signal 'invalid-function `(,object))))) | |
227 | ||
228 | (defun apply (function &rest arguments) | |
229 | (%funcall (@ (guile) apply) | |
230 | (@ (guile) apply) | |
231 | (%indirect-function function) | |
232 | arguments)) | |
233 | ||
234 | (defun funcall (function &rest arguments) | |
235 | (%funcall (@ (guile) apply) | |
236 | (%indirect-function function) | |
237 | arguments)) | |
238 | ||
0faf3965 RT |
239 | (defun autoload-do-load (fundef &optional funname macro-only) |
240 | (and (load (cadr fundef)) | |
241 | (%indirect-function funname))) | |
242 | ||
243 | (defun fset (symbol definition) | |
244 | (funcall (@ (language elisp runtime) set-symbol-function!) | |
245 | symbol | |
246 | definition)) | |
247 | ||
248 | (defun eq (obj1 obj2) | |
249 | (if obj1 | |
250 | (%funcall (@ (guile) eq?) obj1 obj2) | |
251 | (if obj2 nil t))) | |
252 | ||
253 | (defun nthcdr (n list) | |
254 | (let ((i 0)) | |
255 | (while (< i n) | |
256 | (setq list (cdr list) | |
257 | i (+ i 1))) | |
258 | list)) | |
259 | ||
260 | (defun nth (n list) | |
261 | (car (nthcdr n list))) | |
262 | ||
b05ca4ab BT |
263 | (defun fset (symbol definition) |
264 | (funcall (@ (language elisp runtime) set-symbol-function!) | |
265 | symbol | |
0faf3965 RT |
266 | (cond |
267 | ((%funcall (@ (guile) procedure?) definition) | |
268 | definition) | |
269 | ((and (consp definition) | |
270 | (eq (car definition) 'macro)) | |
271 | (if (%funcall (@ (guile) procedure?) (cdr definition)) | |
272 | definition | |
273 | (cons 'macro | |
274 | (funcall (@ (language elisp falias) make-falias) | |
275 | (function | |
276 | (lambda (&rest args) (apply (cdr definition) args))) | |
277 | (cdr definition))))) | |
278 | ((and (consp definition) | |
279 | (eq (car definition) 'autoload)) | |
280 | (if (or (eq (nth 4 definition) 'macro) | |
281 | (eq (nth 4 definition) t)) | |
282 | (cons 'macro | |
283 | (funcall | |
284 | (@ (language elisp falias) make-falias) | |
285 | (function (lambda (&rest args) | |
286 | (apply (cdr (autoload-do-load definition symbol nil)) args))) | |
287 | definition)) | |
288 | (funcall | |
289 | (@ (language elisp falias) make-falias) | |
290 | (function (lambda (&rest args) | |
291 | (apply (autoload-do-load definition symbol nil) args))) | |
292 | definition))) | |
954ff80f RT |
293 | ((and (symbolp definition) |
294 | (let ((fn (symbol-function definition))) | |
295 | (and (consp fn) | |
296 | (or (eq (car fn) 'macro) | |
297 | (and (eq (car fn) 'autoload) | |
298 | (or (eq (nth 4 fn) 'macro) | |
299 | (eq (nth 4 fn) t))))))) | |
300 | (cons 'macro | |
301 | (funcall | |
302 | (@ (language elisp falias) make-falias) | |
303 | (function (lambda (&rest args) `(,definition ,@args))) | |
304 | definition))) | |
0faf3965 | 305 | (t |
b05ca4ab | 306 | (funcall (@ (language elisp falias) make-falias) |
0faf3965 RT |
307 | (function (lambda (&rest args) (apply definition args))) |
308 | definition)))) | |
b05ca4ab BT |
309 | definition) |
310 | ||
0faf3965 | 311 | (defun gload (file) |
5bcc6d9e BT |
312 | (funcall (@ (system base compile) compile-file) |
313 | file | |
314 | (funcall (@ (guile) symbol->keyword) 'from) | |
315 | 'elisp | |
316 | (funcall (@ (guile) symbol->keyword) 'to) | |
317 | 'value) | |
318 | t) | |
319 | ||
9b15703d BT |
320 | ;;; Equality predicates |
321 | ||
0ab2a63a BT |
322 | (defun eql (obj1 obj2) |
323 | (if obj1 | |
324 | (funcall (@ (guile) eqv?) obj1 obj2) | |
325 | (null obj2))) | |
326 | ||
327 | (defun equal (obj1 obj2) | |
328 | (if obj1 | |
329 | (funcall (@ (guile) equal?) obj1 obj2) | |
330 | (null obj2))) | |
9b15703d | 331 | |
85bc6238 BT |
332 | ;;; Symbols |
333 | ||
b05ca4ab BT |
334 | ;;; `symbolp' and `symbol-function' are defined above. |
335 | ||
5c65ee51 | 336 | (fset 'symbol-name (@ (guile) symbol->string)) |
85bc6238 | 337 | (fset 'symbol-value (@ (language elisp runtime) symbol-value)) |
85bc6238 BT |
338 | (fset 'set (@ (language elisp runtime) set-symbol-value!)) |
339 | (fset 'makunbound (@ (language elisp runtime) makunbound!)) | |
340 | (fset 'fmakunbound (@ (language elisp runtime) fmakunbound!)) | |
341 | (fset 'boundp (@ (language elisp runtime) symbol-bound?)) | |
342 | (fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) | |
5c65ee51 | 343 | (fset 'intern (@ (guile) string->symbol)) |
85bc6238 | 344 | |
0faf3965 RT |
345 | ;(defun defvaralias (new-alias base-variable &optional docstring) |
346 | ; (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) | |
347 | ; base-variable))) | |
348 | ; (funcall (@ (language elisp runtime) set-symbol-fluid!) | |
349 | ; new-alias | |
350 | ; fluid) | |
351 | ; base-variable)) | |
14b288ce | 352 | |
9b15703d BT |
353 | ;;; Numerical type predicates |
354 | ||
355 | (defun floatp (object) | |
356 | (and (funcall (@ (guile) real?) object) | |
357 | (or (funcall (@ (guile) inexact?) object) | |
358 | (null (funcall (@ (guile) integer?) object))))) | |
359 | ||
360 | (defun integerp (object) | |
fc45b7e8 BT |
361 | (and (funcall (@ (guile) integer?) object) |
362 | (funcall (@ (guile) exact?) object))) | |
9b15703d BT |
363 | |
364 | (defun numberp (object) | |
365 | (funcall (@ (guile) real?) object)) | |
366 | ||
367 | (defun wholenump (object) | |
fc45b7e8 | 368 | (and (integerp object) (>= object 0))) |
9b15703d BT |
369 | |
370 | (defun zerop (object) | |
371 | (= object 0)) | |
372 | ||
373 | ;;; Numerical comparisons | |
374 | ||
375 | (fset '= (@ (guile) =)) | |
376 | ||
377 | (defun /= (num1 num2) | |
378 | (null (= num1 num2))) | |
379 | ||
380 | (fset '< (@ (guile) <)) | |
381 | (fset '<= (@ (guile) <=)) | |
382 | (fset '> (@ (guile) >)) | |
383 | (fset '>= (@ (guile) >=)) | |
384 | ||
385 | (defun max (&rest numbers) | |
386 | (apply (@ (guile) max) numbers)) | |
387 | ||
388 | (defun min (&rest numbers) | |
389 | (apply (@ (guile) min) numbers)) | |
390 | ||
391 | ;;; Arithmetic functions | |
392 | ||
393 | (fset '1+ (@ (guile) 1+)) | |
394 | (fset '1- (@ (guile) 1-)) | |
395 | (fset '+ (@ (guile) +)) | |
396 | (fset '- (@ (guile) -)) | |
397 | (fset '* (@ (guile) *)) | |
398 | (fset '% (@ (guile) modulo)) | |
399 | (fset 'abs (@ (guile) abs)) | |
400 | ||
401 | ;;; Floating-point rounding | |
402 | ||
403 | (fset 'ffloor (@ (guile) floor)) | |
404 | (fset 'fceiling (@ (guile) ceiling)) | |
405 | (fset 'ftruncate (@ (guile) truncate)) | |
406 | (fset 'fround (@ (guile) round)) | |
407 | ||
408 | ;;; Numeric conversion | |
409 | ||
410 | (defun float (arg) | |
411 | (if (numberp arg) | |
412 | (funcall (@ (guile) exact->inexact) arg) | |
413 | (signal 'wrong-type-argument `(numberp ,arg)))) | |
414 | ||
415 | ;;; List predicates | |
416 | ||
9b15703d BT |
417 | (fset 'not #'null) |
418 | ||
419 | (defun atom (object) | |
420 | (null (consp object))) | |
421 | ||
9b15703d BT |
422 | (defun nlistp (object) |
423 | (null (listp object))) | |
424 | ||
425 | ;;; Lists | |
426 | ||
427 | (fset 'cons (@ (guile) cons)) | |
428 | (fset 'list (@ (guile) list)) | |
429 | (fset 'make-list (@ (guile) make-list)) | |
430 | (fset 'append (@ (guile) append)) | |
431 | (fset 'reverse (@ (guile) reverse)) | |
12c00a04 | 432 | (fset 'nreverse (@ (guile) reverse!)) |
9b15703d | 433 | |
9b15703d BT |
434 | (defun car-safe (object) |
435 | (if (consp object) | |
436 | (car object) | |
437 | nil)) | |
438 | ||
439 | (defun cdr-safe (object) | |
440 | (if (consp object) | |
441 | (cdr object) | |
442 | nil)) | |
443 | ||
444 | (defun setcar (cell newcar) | |
445 | (if (consp cell) | |
446 | (progn | |
447 | (funcall (@ (guile) set-car!) cell newcar) | |
448 | newcar) | |
449 | (signal 'wrong-type-argument `(consp ,cell)))) | |
450 | ||
451 | (defun setcdr (cell newcdr) | |
452 | (if (consp cell) | |
453 | (progn | |
454 | (funcall (@ (guile) set-cdr!) cell newcdr) | |
455 | newcdr) | |
456 | (signal 'wrong-type-argument `(consp ,cell)))) | |
457 | ||
df9cd3b4 BT |
458 | (defun %member (elt list test) |
459 | (cond | |
460 | ((null list) nil) | |
461 | ((consp list) | |
462 | (if (funcall test elt (car list)) | |
463 | list | |
464 | (%member elt (cdr list) test))) | |
465 | (t (signal 'wrong-type-argument `(listp ,list))))) | |
466 | ||
467 | (defun member (elt list) | |
468 | (%member elt list #'equal)) | |
469 | ||
470 | (defun memql (elt list) | |
471 | (%member elt list #'eql)) | |
472 | ||
473 | (defun memq (elt list) | |
474 | (%member elt list #'eq)) | |
475 | ||
12c00a04 BT |
476 | (defun assoc (key list) |
477 | (funcall (@ (srfi srfi-1) assoc) key list #'equal)) | |
478 | ||
479 | (defun assq (key list) | |
480 | (funcall (@ (srfi srfi-1) assoc) key list #'eq)) | |
481 | ||
482 | (defun rplaca (cell newcar) | |
483 | (funcall (@ (guile) set-car!) cell newcar) | |
484 | newcar) | |
485 | ||
486 | (defun rplacd (cell newcdr) | |
487 | (funcall (@ (guile) set-cdr!) cell newcdr) | |
488 | newcdr) | |
489 | ||
490 | (defun caar (x) | |
491 | (car (car x))) | |
492 | ||
493 | (defun cadr (x) | |
494 | (car (cdr x))) | |
495 | ||
496 | (defun cdar (x) | |
497 | (cdr (car x))) | |
498 | ||
499 | (defun cddr (x) | |
500 | (cdr (cdr x))) | |
501 | ||
502 | (defmacro dolist (spec &rest body) | |
503 | (apply #'(lambda (var list &optional result) | |
0faf3965 RT |
504 | (list 'progn |
505 | (list 'mapc | |
506 | (cons 'lambda (cons (list var) body)) | |
507 | list) | |
508 | result)) | |
12c00a04 BT |
509 | spec)) |
510 | ||
8f2f6566 BT |
511 | ;;; Strings |
512 | ||
513 | (defun string (&rest characters) | |
514 | (funcall (@ (guile) list->string) | |
515 | (mapcar (@ (guile) integer->char) characters))) | |
516 | ||
12c00a04 BT |
517 | (defun stringp (object) |
518 | (funcall (@ (guile) string?) object)) | |
519 | ||
520 | (defun string-equal (s1 s2) | |
521 | (let ((s1 (if (symbolp s1) (symbol-name s1) s1)) | |
522 | (s2 (if (symbolp s2) (symbol-name s2) s2))) | |
523 | (funcall (@ (guile) string=?) s1 s2))) | |
524 | ||
525 | (fset 'string= 'string-equal) | |
526 | ||
527 | (defun substring (string from &optional to) | |
528 | (apply (@ (guile) substring) string from (if to (list to) nil))) | |
529 | ||
530 | (defun upcase (obj) | |
531 | (funcall (@ (guile) string-upcase) obj)) | |
532 | ||
533 | (defun downcase (obj) | |
534 | (funcall (@ (guile) string-downcase) obj)) | |
535 | ||
536 | (defun string-match (regexp string &optional start) | |
537 | (let ((m (funcall (@ (ice-9 regex) string-match) | |
538 | regexp | |
539 | string | |
540 | (or start 0)))) | |
541 | (if m | |
542 | (funcall (@ (ice-9 regex) match:start) m 0) | |
543 | nil))) | |
544 | ||
545 | ;; Vectors | |
546 | ||
547 | (defun make-vector (length init) | |
548 | (funcall (@ (guile) make-vector) length init)) | |
549 | ||
9b15703d BT |
550 | ;;; Sequences |
551 | ||
ebc30e3f BT |
552 | (defun length (sequence) |
553 | (funcall (if (listp sequence) | |
554 | (@ (guile) length) | |
555 | (@ (guile) generalized-vector-length)) | |
556 | sequence)) | |
8f2f6566 BT |
557 | |
558 | (defun mapcar (function sequence) | |
559 | (funcall (@ (guile) map) function sequence)) | |
12ca82ca | 560 | |
12c00a04 BT |
561 | (defun mapc (function sequence) |
562 | (funcall (@ (guile) for-each) function sequence) | |
563 | sequence) | |
564 | ||
565 | (defun aref (array idx) | |
566 | (funcall (@ (guile) generalized-vector-ref) array idx)) | |
567 | ||
568 | (defun aset (array idx newelt) | |
569 | (funcall (@ (guile) generalized-vector-set!) array idx newelt) | |
570 | newelt) | |
571 | ||
572 | (defun concat (&rest sequences) | |
573 | (apply (@ (guile) string-append) sequences)) | |
574 | ||
12ca82ca BT |
575 | ;;; Property lists |
576 | ||
577 | (defun %plist-member (plist property test) | |
76c50ec5 BT |
578 | (cond |
579 | ((null plist) nil) | |
580 | ((consp plist) | |
581 | (if (funcall test (car plist) property) | |
582 | (cdr plist) | |
583 | (%plist-member (cdr (cdr plist)) property test))) | |
584 | (t (signal 'wrong-type-argument `(listp ,plist))))) | |
12ca82ca BT |
585 | |
586 | (defun %plist-get (plist property test) | |
587 | (car (%plist-member plist property test))) | |
588 | ||
589 | (defun %plist-put (plist property value test) | |
13f022c9 | 590 | (let ((x (%plist-member plist property test))) |
12ca82ca BT |
591 | (if x |
592 | (progn (setcar x value) plist) | |
593 | (cons property (cons value plist))))) | |
594 | ||
595 | (defun plist-get (plist property) | |
596 | (%plist-get plist property #'eq)) | |
597 | ||
598 | (defun plist-put (plist property value) | |
599 | (%plist-put plist property value #'eq)) | |
600 | ||
601 | (defun plist-member (plist property) | |
602 | (%plist-member plist property #'eq)) | |
603 | ||
604 | (defun lax-plist-get (plist property) | |
605 | (%plist-get plist property #'equal)) | |
606 | ||
607 | (defun lax-plist-put (plist property value) | |
608 | (%plist-put plist property value #'equal)) | |
609 | ||
610 | (defvar plist-function (funcall (@ (guile) make-object-property))) | |
611 | ||
612 | (defun symbol-plist (symbol) | |
613 | (funcall plist-function symbol)) | |
614 | ||
615 | (defun setplist (symbol plist) | |
616 | (funcall (funcall (@ (guile) setter) plist-function) symbol plist)) | |
617 | ||
618 | (defun get (symbol propname) | |
619 | (plist-get (symbol-plist symbol) propname)) | |
620 | ||
621 | (defun put (symbol propname value) | |
622 | (setplist symbol (plist-put (symbol-plist symbol) propname value))) | |
5950f674 BT |
623 | |
624 | ;;; Nonlocal exits | |
625 | ||
626 | (defmacro condition-case (var bodyform &rest handlers) | |
627 | (let ((key (make-symbol "key")) | |
628 | (error-symbol (make-symbol "error-symbol")) | |
629 | (data (make-symbol "data")) | |
630 | (conditions (make-symbol "conditions"))) | |
631 | (flet ((handler->cond-clause (handler) | |
632 | `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions)) | |
633 | (if (consp (car handler)) | |
634 | (car handler) | |
635 | (list (car handler))))) | |
636 | ,@(cdr handler)))) | |
637 | `(funcall (@ (guile) catch) | |
638 | 'elisp-condition | |
639 | #'(lambda () ,bodyform) | |
640 | #'(lambda (,key ,error-symbol ,data) | |
b07a7449 | 641 | (declare (lexical ,key ,error-symbol ,data)) |
5950f674 BT |
642 | (let ((,conditions |
643 | (get ,error-symbol 'error-conditions)) | |
644 | ,@(if var | |
645 | `((,var (cons ,error-symbol ,data))) | |
646 | '())) | |
b07a7449 BT |
647 | (declare (lexical ,conditions |
648 | ,@(if var `(,var) '()))) | |
5950f674 BT |
649 | (cond ,@(mapcar #'handler->cond-clause handlers) |
650 | (t (signal ,error-symbol ,data))))))))) | |
ce9b7cc2 BT |
651 | |
652 | (put 'error 'error-conditions '(error)) | |
653 | (put 'wrong-type-argument 'error-conditions '(wrong-type-argument error)) | |
654 | (put 'invalid-function 'error-conditions '(invalid-function error)) | |
655 | (put 'no-catch 'error-conditions '(no-catch error)) | |
8fb67871 BT |
656 | (put 'throw 'error-conditions '(throw)) |
657 | ||
85b3dd6c BT |
658 | (defvar %catch nil) |
659 | ||
8fb67871 BT |
660 | (defmacro catch (tag &rest body) |
661 | (let ((tag-value (make-symbol "tag-value")) | |
662 | (c (make-symbol "c")) | |
663 | (data (make-symbol "data"))) | |
664 | `(let ((,tag-value ,tag)) | |
b07a7449 | 665 | (declare (lexical ,tag-value)) |
8fb67871 | 666 | (condition-case ,c |
85b3dd6c BT |
667 | (let ((%catch t)) |
668 | ,@body) | |
8fb67871 BT |
669 | (throw |
670 | (let ((,data (cdr ,c))) | |
b07a7449 | 671 | (declare (lexical ,data)) |
8fb67871 BT |
672 | (if (eq (car ,data) ,tag-value) |
673 | (car (cdr ,data)) | |
85b3dd6c | 674 | (apply #'throw ,data)))))))) |
ce9b7cc2 | 675 | |
8fb67871 | 676 | (defun throw (tag value) |
85b3dd6c | 677 | (signal (if %catch 'throw 'no-catch) (list tag value))) |
39864d20 BT |
678 | |
679 | ;;; I/O | |
680 | ||
681 | (defun princ (object) | |
682 | (funcall (@ (guile) display) object)) | |
683 | ||
684 | (defun print (object) | |
685 | (funcall (@ (guile) write) object)) | |
686 | ||
0faf3965 RT |
687 | (defun prin1 (object) |
688 | (funcall (@ (guile) write) object)) | |
689 | ||
39864d20 BT |
690 | (defun terpri () |
691 | (funcall (@ (guile) newline))) | |
692 | ||
693 | (defun format* (stream string &rest args) | |
694 | (apply (@ (guile) format) stream string args)) | |
43ff6804 BT |
695 | |
696 | (defun send-string-to-terminal (string) | |
697 | (princ string)) | |
698 | ||
699 | (defun read-from-minibuffer (prompt &rest ignore) | |
700 | (princ prompt) | |
701 | (let ((value (funcall (@ (ice-9 rdelim) read-line)))) | |
702 | (if (funcall (@ (guile) eof-object?) value) | |
703 | "" | |
704 | value))) | |
705 | ||
706 | (defun prin1-to-string (object) | |
707 | (format* nil "~S" object)) | |
52d24724 BT |
708 | |
709 | ;; Random number generation | |
710 | ||
711 | (defvar %random-state (funcall (@ (guile) copy-random-state) | |
712 | (@ (guile) *random-state*))) | |
713 | ||
714 | (defun random (&optional limit) | |
0faf3965 RT |
715 | (if (eq limit t) |
716 | (setq %random-state | |
717 | (funcall (@ (guile) random-state-from-platform)))) | |
718 | (funcall (@ (guile) random) | |
719 | (if (wholenump limit) | |
720 | limit | |
721 | (@ (guile) most-positive-fixnum)) | |
722 | %random-state)) | |
723 | ||
724 | (defmacro save-excursion (&rest body) | |
725 | `(call-with-save-excursion #'(lambda () ,@body))) | |
726 | ||
727 | (defmacro save-current-buffer (&rest body) | |
728 | `(call-with-save-current-buffer #'(lambda () ,@body))) | |
729 | ||
730 | (defmacro save-restriction (&rest body) | |
731 | `(call-with-save-restriction #'(lambda () ,@body))) | |
732 | ||
733 | (defmacro track-mouse (&rest body) | |
734 | `(call-with-track-mouse #'(lambda () ,@body))) | |
735 | ||
736 | (defmacro setq-default (var value &rest args) | |
737 | `(progn (set-default ',var ,value) | |
738 | ,(if (null args) | |
739 | var | |
740 | `(setq-default ,@args)))) | |
741 | ||
742 | (defmacro catch (tag &rest body) | |
743 | `(call-with-catch ,tag #'(lambda () ,@body))) | |
744 | ||
745 | (defmacro condition-case (var bodyform &rest args) | |
746 | (if (consp args) | |
747 | (let* ((handler (car args)) | |
748 | (handlers (cdr args)) | |
749 | (handler-conditions (car handler)) | |
750 | (handler-body (cdr handler))) | |
751 | `(call-with-handler ',var | |
752 | ',handler-conditions | |
753 | #'(lambda () ,@handler-body) | |
754 | #'(lambda () | |
755 | (condition-case ,var | |
756 | ,bodyform | |
757 | ,@handlers)))) | |
758 | bodyform)) | |
759 | ||
760 | (defun backtrace-frame (nframes) | |
761 | (let* ((stack (funcall (@ (guile) make-stack) t)) | |
762 | (frame (stack-ref stack nframes)) | |
763 | (proc (funcall (@ (guile) frame-procedure) frame)) | |
764 | (pname (or (and (%functionp proc) | |
765 | (funcall (@ (guile) procedure-name) proc)) | |
766 | proc)) | |
767 | (args (funcall (@ (guile) frame-arguments) frame))) | |
768 | (cons t (cons pname args)))) | |
769 | ||
a930be6f | 770 | (defun guile-backtrace (&rest args) |
0faf3965 | 771 | (interactive) |
a930be6f | 772 | (let* ((stack (apply (@ (guile) make-stack) t args)) |
0faf3965 RT |
773 | (frame (funcall (@ (guile) stack-ref) stack 1)) |
774 | (space (funcall (@ (guile) integer->char) 32))) | |
775 | (while frame | |
776 | (princ (string 32 32)) | |
777 | (let ((proc (funcall (@ (guile) frame-procedure) frame))) | |
778 | (prin1 (or (and (%functionp proc) | |
779 | (funcall (@ (guile) procedure-name) proc)) | |
780 | proc))) | |
781 | (prin1 (funcall (@ (guile) frame-arguments) frame)) | |
782 | (terpri) | |
783 | (setq frame (funcall (@ (guile) frame-previous) frame))) | |
784 | nil)) | |
785 | ||
a930be6f RT |
786 | (defun backtrace () |
787 | (guile-backtrace t)) | |
788 | ||
0faf3965 RT |
789 | (defun %set-eager-macroexpansion-mode (ignore) |
790 | nil) | |
f900b12a RT |
791 | |
792 | (%define-compiler-macro require (form) | |
793 | `(eval-when (:compile-toplevel :load-toplevel :execute) | |
794 | (funcall #'require ,@(cdr form)))) |