1 ;;; Guile Emacs Lisp -*- lexical-binding: t -*-
3 ;;; Copyright (C) 2011 Free Software Foundation, Inc.
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.
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.
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
22 (defmacro @ (module symbol
)
23 `(guile-ref ,module
,symbol
))
25 (defmacro eval-and-compile
(&rest body
)
27 (eval-when-compile ,@body
)
34 (%funcall
(@ (guile) pair?
) object
))
36 (if object
(consp object
) t
))
38 (if list
(%funcall
(@ (guile) car
) list
) nil
))
40 (if list
(%funcall
(@ (guile) cdr
) list
) nil
))
41 (defun make-symbol (name)
42 (%funcall
(@ (guile) make-symbol
) name
))
43 (defun signal (error-symbol data
)
44 (%funcall
(@ (guile) throw
) 'elisp-condition error-symbol data
)))
46 (defmacro lambda
(&rest cdr
)
49 (defmacro prog1
(first &rest body
)
50 (let ((temp (make-symbol "prog1-temp")))
51 `(let ((,temp
,first
))
52 (declare (lexical ,temp
))
56 (defmacro prog2
(form1 form2
&rest body
)
57 `(progn ,form1
(prog1 ,form2
,@body
)))
59 (defmacro cond
(&rest clauses
)
62 (let ((first (car clauses
))
65 (let ((condition (car first
))
68 (let ((temp (make-symbol "cond-temp")))
69 `(let ((,temp
,condition
))
70 (declare (lexical ,temp
))
77 (signal 'wrong-type-argument
`(listp ,first
))))))
79 (defmacro and
(&rest conditions
)
80 (cond ((null conditions
) t
)
81 ((null (cdr conditions
)) (car conditions
))
82 (t `(if ,(car conditions
)
83 (and ,@(cdr conditions
))
86 (defmacro or
(&rest conditions
)
87 (cond ((null conditions
) nil
)
88 ((null (cdr conditions
)) (car conditions
))
89 (t (let ((temp (make-symbol "or-temp")))
90 `(let ((,temp
,(car conditions
)))
91 (declare (lexical ,temp
))
94 (or ,@(cdr conditions
))))))))
96 (defmacro lexical-let
(bindings &rest body
)
97 (labels ((loop (list vars
)
100 (declare (lexical ,@vars
))
103 (if (consp (car list
))
104 `(,(car (car list
)) ,@vars
)
105 `(,(car list
) ,@vars
))))))
106 (loop bindings
'())))
108 (defmacro lexical-let
* (bindings &rest body
)
109 (labels ((loop (list vars
)
112 (declare (lexical ,@vars
))
115 (if (consp (car list
))
116 (cons (car (car list
)) vars
)
117 (cons (car list
) vars
))))))
118 (loop bindings
'())))
120 (defmacro while
(test &rest body
)
121 (let ((loop (make-symbol "loop")))
124 (progn ,@body
(,loop
))
128 (defmacro unwind-protect
(bodyform &rest unwindforms
)
129 `(funcall (@ (guile) dynamic-wind
)
131 #'(lambda () ,bodyform
)
132 #'(lambda () ,@unwindforms
)))
134 (defmacro when
(cond &rest body
)
138 (defmacro unless
(cond &rest body
)
142 (defun symbolp (object)
143 (%funcall
(@ (guile) symbol?
) object
))
145 (defun functionp (object)
146 (%funcall
(@ (guile) procedure?
) object
))
148 (defun symbol-function (symbol)
149 (let ((f (%funcall
(@ (language elisp runtime
) symbol-function
)
151 (if (%funcall
(@ (language elisp falias
) falias?
) f
)
152 (%funcall
(@ (language elisp falias
) falias-object
) f
)
156 (%funcall
(@ (system base compile
) compile
)
158 (%funcall
(@ (guile) symbol-
>keyword
) 'from
)
160 (%funcall
(@ (guile) symbol-
>keyword
) 'to
)
163 (defun %indirect-function
(object)
167 ((symbolp object
) ;++ cycle detection
168 (%indirect-function
(symbol-function object
)))
170 (eval `(function ,object
)))
172 (signal 'invalid-function
`(,object
)))))
174 (defun apply (function &rest arguments
)
175 (%funcall
(@ (guile) apply
)
177 (%indirect-function function
)
180 (defun funcall (function &rest arguments
)
181 (%funcall
(@ (guile) apply
)
182 (%indirect-function function
)
185 (defun fset (symbol definition
)
186 (funcall (@ (language elisp runtime
) set-symbol-function
!)
188 (if (functionp definition
)
190 (funcall (@ (language elisp falias
) make-falias
)
191 #'(lambda (&rest args
) (apply definition args
))
196 (funcall (@ (system base compile
) compile-file
)
198 (funcall (@ (guile) symbol-
>keyword
) 'from
)
200 (funcall (@ (guile) symbol-
>keyword
) 'to
)
204 ;;; Equality predicates
206 (defun eq (obj1 obj2
)
208 (funcall (@ (guile) eq?
) obj1 obj2
)
211 (defun eql (obj1 obj2
)
213 (funcall (@ (guile) eqv?
) obj1 obj2
)
216 (defun equal (obj1 obj2
)
218 (funcall (@ (guile) equal?
) obj1 obj2
)
223 ;;; `symbolp' and `symbol-function' are defined above.
225 (fset 'symbol-name
(@ (guile) symbol-
>string
))
226 (fset 'symbol-value
(@ (language elisp runtime
) symbol-value
))
227 (fset 'set
(@ (language elisp runtime
) set-symbol-value
!))
228 (fset 'makunbound
(@ (language elisp runtime
) makunbound
!))
229 (fset 'fmakunbound
(@ (language elisp runtime
) fmakunbound
!))
230 (fset 'boundp
(@ (language elisp runtime
) symbol-bound?
))
231 (fset 'fboundp
(@ (language elisp runtime
) symbol-fbound?
))
232 (fset 'intern
(@ (guile) string-
>symbol
))
234 (defun defvaralias (new-alias base-variable
&optional docstring
)
235 (let ((fluid (funcall (@ (language elisp runtime
) symbol-fluid
)
237 (funcall (@ (language elisp runtime
) set-symbol-fluid
!)
242 ;;; Numerical type predicates
244 (defun floatp (object)
245 (and (funcall (@ (guile) real?
) object
)
246 (or (funcall (@ (guile) inexact?
) object
)
247 (null (funcall (@ (guile) integer?
) object
)))))
249 (defun integerp (object)
250 (and (funcall (@ (guile) integer?
) object
)
251 (funcall (@ (guile) exact?
) object
)))
253 (defun numberp (object)
254 (funcall (@ (guile) real?
) object
))
256 (defun wholenump (object)
257 (and (integerp object
) (>= object
0)))
259 (defun zerop (object)
262 ;;; Numerical comparisons
264 (fset '= (@ (guile) =))
266 (defun /= (num1 num2
)
267 (null (= num1 num2
)))
269 (fset '< (@ (guile) <))
270 (fset '<= (@ (guile) <=))
271 (fset '> (@ (guile) >))
272 (fset '>= (@ (guile) >=))
274 (defun max (&rest numbers
)
275 (apply (@ (guile) max
) numbers
))
277 (defun min (&rest numbers
)
278 (apply (@ (guile) min
) numbers
))
280 ;;; Arithmetic functions
282 (fset '1+ (@ (guile) 1+))
283 (fset '1-
(@ (guile) 1-
))
284 (fset '+ (@ (guile) +))
285 (fset '-
(@ (guile) -
))
286 (fset '* (@ (guile) *))
287 (fset '%
(@ (guile) modulo
))
288 (fset 'abs
(@ (guile) abs
))
290 ;;; Floating-point rounding
292 (fset 'ffloor
(@ (guile) floor
))
293 (fset 'fceiling
(@ (guile) ceiling
))
294 (fset 'ftruncate
(@ (guile) truncate
))
295 (fset 'fround
(@ (guile) round
))
297 ;;; Numeric conversion
301 (funcall (@ (guile) exact-
>inexact
) arg
)
302 (signal 'wrong-type-argument
`(numberp ,arg
))))
309 (null (consp object
)))
311 (defun nlistp (object)
312 (null (listp object
)))
316 (fset 'cons
(@ (guile) cons
))
317 (fset 'list
(@ (guile) list
))
318 (fset 'make-list
(@ (guile) make-list
))
319 (fset 'append
(@ (guile) append
))
320 (fset 'reverse
(@ (guile) reverse
))
321 (fset 'nreverse
(@ (guile) reverse
!))
323 (defun car-safe (object)
328 (defun cdr-safe (object)
333 (defun setcar (cell newcar
)
336 (funcall (@ (guile) set-car
!) cell newcar
)
338 (signal 'wrong-type-argument
`(consp ,cell
))))
340 (defun setcdr (cell newcdr
)
343 (funcall (@ (guile) set-cdr
!) cell newcdr
)
345 (signal 'wrong-type-argument
`(consp ,cell
))))
347 (defun nthcdr (n list
)
350 (setq list
(cdr list
)
355 (car (nthcdr n list
)))
357 (defun %member
(elt list test
)
361 (if (funcall test elt
(car list
))
363 (%member elt
(cdr list
) test
)))
364 (t (signal 'wrong-type-argument
`(listp ,list
)))))
366 (defun member (elt list
)
367 (%member elt list
#'equal
))
369 (defun memql (elt list
)
370 (%member elt list
#'eql
))
372 (defun memq (elt list
)
373 (%member elt list
#'eq
))
375 (defun assoc (key list
)
376 (funcall (@ (srfi srfi-1
) assoc
) key list
#'equal
))
378 (defun assq (key list
)
379 (funcall (@ (srfi srfi-1
) assoc
) key list
#'eq
))
381 (defun rplaca (cell newcar
)
382 (funcall (@ (guile) set-car
!) cell newcar
)
385 (defun rplacd (cell newcdr
)
386 (funcall (@ (guile) set-cdr
!) cell newcdr
)
401 (defmacro dolist
(spec &rest body
)
402 (apply #'(lambda (var list
&optional result
)
403 `(mapc #'(lambda (,var
)
411 (defun string (&rest characters
)
412 (funcall (@ (guile) list-
>string
)
413 (mapcar (@ (guile) integer-
>char
) characters
)))
415 (defun stringp (object)
416 (funcall (@ (guile) string?
) object
))
418 (defun string-equal (s1 s2
)
419 (let ((s1 (if (symbolp s1
) (symbol-name s1
) s1
))
420 (s2 (if (symbolp s2
) (symbol-name s2
) s2
)))
421 (funcall (@ (guile) string
=?
) s1 s2
)))
423 (fset 'string
= 'string-equal
)
425 (defun substring (string from
&optional to
)
426 (apply (@ (guile) substring
) string from
(if to
(list to
) nil
)))
429 (funcall (@ (guile) string-upcase
) obj
))
431 (defun downcase (obj)
432 (funcall (@ (guile) string-downcase
) obj
))
434 (defun string-match (regexp string
&optional start
)
435 (let ((m (funcall (@ (ice-9 regex
) string-match
)
440 (funcall (@ (ice-9 regex
) match
:start
) m
0)
445 (defun make-vector (length init
)
446 (funcall (@ (guile) make-vector
) length init
))
450 (defun length (sequence)
451 (funcall (if (listp sequence
)
453 (@ (guile) generalized-vector-length
))
456 (defun mapcar (function sequence
)
457 (funcall (@ (guile) map
) function sequence
))
459 (defun mapc (function sequence
)
460 (funcall (@ (guile) for-each
) function sequence
)
463 (defun aref (array idx
)
464 (funcall (@ (guile) generalized-vector-ref
) array idx
))
466 (defun aset (array idx newelt
)
467 (funcall (@ (guile) generalized-vector-set
!) array idx newelt
)
470 (defun concat (&rest sequences
)
471 (apply (@ (guile) string-append
) sequences
))
475 (defun %plist-member
(plist property test
)
479 (if (funcall test
(car plist
) property
)
481 (%plist-member
(cdr (cdr plist
)) property test
)))
482 (t (signal 'wrong-type-argument
`(listp ,plist
)))))
484 (defun %plist-get
(plist property test
)
485 (car (%plist-member plist property test
)))
487 (defun %plist-put
(plist property value test
)
488 (let ((x (%plist-member plist property test
)))
490 (progn (setcar x value
) plist
)
491 (cons property
(cons value plist
)))))
493 (defun plist-get (plist property
)
494 (%plist-get plist property
#'eq
))
496 (defun plist-put (plist property value
)
497 (%plist-put plist property value
#'eq
))
499 (defun plist-member (plist property
)
500 (%plist-member plist property
#'eq
))
502 (defun lax-plist-get (plist property
)
503 (%plist-get plist property
#'equal
))
505 (defun lax-plist-put (plist property value
)
506 (%plist-put plist property value
#'equal
))
508 (defvar plist-function
(funcall (@ (guile) make-object-property
)))
510 (defun symbol-plist (symbol)
511 (funcall plist-function symbol
))
513 (defun setplist (symbol plist
)
514 (funcall (funcall (@ (guile) setter
) plist-function
) symbol plist
))
516 (defun get (symbol propname
)
517 (plist-get (symbol-plist symbol
) propname
))
519 (defun put (symbol propname value
)
520 (setplist symbol
(plist-put (symbol-plist symbol
) propname value
)))
524 (defmacro condition-case
(var bodyform
&rest handlers
)
525 (let ((key (make-symbol "key"))
526 (error-symbol (make-symbol "error-symbol"))
527 (data (make-symbol "data"))
528 (conditions (make-symbol "conditions")))
529 (flet ((handler->cond-clause
(handler)
530 `((or ,@(mapcar #'(lambda (c) `(memq ',c
,conditions
))
531 (if (consp (car handler
))
533 (list (car handler
)))))
535 `(funcall (@ (guile) catch
)
537 #'(lambda () ,bodyform
)
538 #'(lambda (,key
,error-symbol
,data
)
539 (declare (lexical ,key
,error-symbol
,data
))
541 (get ,error-symbol
'error-conditions
))
543 `((,var
(cons ,error-symbol
,data
)))
545 (declare (lexical ,conditions
546 ,@(if var
`(,var
) '())))
547 (cond ,@(mapcar #'handler-
>cond-clause handlers
)
548 (t (signal ,error-symbol
,data
)))))))))
550 (put 'error
'error-conditions
'(error))
551 (put 'wrong-type-argument
'error-conditions
'(wrong-type-argument error
))
552 (put 'invalid-function
'error-conditions
'(invalid-function error
))
553 (put 'no-catch
'error-conditions
'(no-catch error
))
554 (put 'throw
'error-conditions
'(throw))
558 (defmacro catch
(tag &rest body
)
559 (let ((tag-value (make-symbol "tag-value"))
560 (c (make-symbol "c"))
561 (data (make-symbol "data")))
562 `(let ((,tag-value
,tag
))
563 (declare (lexical ,tag-value
))
568 (let ((,data
(cdr ,c
)))
569 (declare (lexical ,data
))
570 (if (eq (car ,data
) ,tag-value
)
572 (apply #'throw
,data
))))))))
574 (defun throw (tag value
)
575 (signal (if %catch
'throw
'no-catch
) (list tag value
)))
579 (defun princ (object)
580 (funcall (@ (guile) display
) object
))
582 (defun print (object)
583 (funcall (@ (guile) write
) object
))
586 (funcall (@ (guile) newline
)))
588 (defun format* (stream string
&rest args
)
589 (apply (@ (guile) format
) stream string args
))
591 (defun send-string-to-terminal (string)
594 (defun read-from-minibuffer (prompt &rest ignore
)
596 (let ((value (funcall (@ (ice-9 rdelim
) read-line
))))
597 (if (funcall (@ (guile) eof-object?
) value
)
601 (defun prin1-to-string (object)
602 (format* nil
"~S" object
))
604 ;; Random number generation
606 (defvar %random-state
(funcall (@ (guile) copy-random-state
)
607 (@ (guile) *random-state
*)))
609 (defun random (&optional limit
)
612 (funcall (@ (guile) random-state-from-platform
))))
613 (funcall (@ (guile) random
)
614 (if (wholenump limit
)
616 (@ (guile) most-positive-fixnum
))