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 @@ (module symbol
)
26 `(guile-private-ref ,module
,symbol
))
28 (defmacro defun
(name args
&rest body
)
29 `(let ((proc (function (lambda ,args
,@body
))))
30 (%funcall
(@ (language elisp runtime
) set-symbol-function
!)
33 (%funcall
(@ (guile) set-procedure-property
!)
37 (defun omega () (omega))
39 (defmacro eval-and-compile
(&rest body
)
41 (eval-when-compile ,@body
)
44 (defmacro %define-compiler-macro
(name args
&rest body
)
47 (@ (language elisp runtime
) set-symbol-plist
!)
52 #'(lambda ,args
,@body
)
53 (%funcall
(@ (language elisp runtime
) symbol-plist
) ',name
)))
56 (defmacro defsubst
(name args
&rest body
)
58 (defun ,name
,args
,@body
)
60 (%define-compiler-macro
,name
(form)
61 (%funcall
(@ (guile) cons
*)
66 (%funcall
(@ (guile) cons
*) 'lambda
',args
',body
))
67 (%funcall
(@ (guile) cdr
) form
))))))
71 (%funcall
(@ (language elisp runtime
) eval-elisp
) form
)))
74 (defsubst null
(object)
75 (declare (lexical object
))
79 (%funcall
(@ (guile) pair?
) x
))
84 (declare (lexical object
))
85 (if object
(consp object
) t
))
87 (declare (lexical list
))
88 (if list
(%funcall
(@ (guile) car
) list
) nil
))
90 (declare (lexical list
))
91 (if list
(%funcall
(@ (guile) cdr
) list
) nil
))
92 (defun make-symbol (name)
93 (%funcall
(@ (guile) make-symbol
) name
))
95 (%funcall
(@ (guile) gensym
)))
96 (defun signal (error-symbol data
)
97 (%funcall
(@ (guile) throw
) 'elisp-condition error-symbol data
)))
99 (defmacro lambda
(&rest cdr
)
102 (defmacro prog1
(first &rest body
)
103 (let ((temp (gensym)))
104 `(let ((,temp
,first
))
105 (declare (lexical ,temp
))
109 (defun interactive (&optional arg
)
112 (defmacro prog2
(form1 form2
&rest body
)
113 `(progn ,form1
(prog1 ,form2
,@body
)))
115 (defmacro cond
(&rest clauses
)
118 (let ((first (car clauses
))
119 (rest (cdr clauses
)))
121 (let ((condition (car first
))
124 (let ((temp (gensym)))
125 `(let ((,temp
,condition
))
126 (declare (lexical ,temp
))
133 (signal 'wrong-type-argument
`(listp ,first
))))))
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
))
142 (defmacro or
(&rest conditions
)
143 (cond ((null conditions
) nil
)
144 ((null (cdr conditions
)) (car conditions
))
145 (t (let ((temp (gensym)))
146 `(let ((,temp
,(car conditions
)))
147 (declare (lexical ,temp
))
150 (or ,@(cdr conditions
))))))))
152 (defmacro lexical-let
(bindings &rest body
)
153 (labels ((loop (list vars
)
156 (declare (lexical ,@vars
))
159 (if (consp (car list
))
160 `(,(car (car list
)) ,@vars
)
161 `(,(car list
) ,@vars
))))))
162 (loop bindings
'())))
164 (defmacro lexical-let
* (bindings &rest body
)
165 (labels ((loop (list vars
)
168 (declare (lexical ,@vars
))
171 (if (consp (car list
))
172 (cons (car (car list
)) vars
)
173 (cons (car list
) vars
))))))
174 (loop bindings
'())))
176 (defmacro while
(test &rest body
)
177 (let ((loop (gensym)))
180 (progn ,@body
(,loop
))
184 (defmacro unwind-protect
(bodyform &rest unwindforms
)
185 `(%funcall
(@ (guile) dynamic-wind
)
187 #'(lambda () ,bodyform
)
188 #'(lambda () ,@unwindforms
)))
190 (defmacro when
(cond &rest body
)
194 (defmacro unless
(cond &rest body
)
198 (defun symbolp (object)
199 (%funcall
(@ (guile) symbol?
) object
))
201 (defun %functionp
(object)
202 (%funcall
(@ (guile) procedure?
) object
))
204 (defun symbol-function (symbol)
205 (let ((f (%funcall
(@ (language elisp runtime
) symbol-function
)
207 (if (%funcall
(@ (language elisp falias
) falias?
) f
)
208 (%funcall
(@ (language elisp falias
) falias-object
) f
)
212 (%funcall
(@ (language elisp runtime
) eval-elisp
) form
))
214 (defun %indirect-function
(object)
219 (signal 'void-function nil
))
220 ((symbolp object
) ;++ cycle detection
222 (%funcall
(@ (language elisp runtime
) symbol-function
) object
)))
224 (eval `(function ,object
)))
226 (signal 'invalid-function
`(,object
)))))
228 (defun apply (function &rest arguments
)
229 (%funcall
(@ (guile) apply
)
231 (%indirect-function function
)
234 (defun funcall (function &rest arguments
)
235 (%funcall
(@ (guile) apply
)
236 (%indirect-function function
)
239 (defun autoload-do-load (fundef &optional funname macro-only
)
240 (and (load (cadr fundef
))
241 (%indirect-function funname
)))
243 (defun fset (symbol definition
)
244 (funcall (@ (language elisp runtime
) set-symbol-function
!)
248 (defun eq (obj1 obj2
)
250 (%funcall
(@ (guile) eq?
) obj1 obj2
)
253 (defun nthcdr (n list
)
256 (setq list
(cdr list
)
261 (car (nthcdr n list
)))
263 (defun fset (symbol definition
)
264 (funcall (@ (language elisp runtime
) set-symbol-function
!)
267 ((%funcall
(@ (guile) procedure?
) definition
)
269 ((and (consp definition
)
270 (eq (car definition
) 'macro
))
271 (if (%funcall
(@ (guile) procedure?
) (cdr definition
))
274 (funcall (@ (language elisp falias
) make-falias
)
276 (lambda (&rest args
) (apply (cdr definition
) args
)))
278 ((and (consp definition
)
279 (eq (car definition
) 'autoload
))
280 (if (or (eq (nth 4 definition
) 'macro
)
281 (eq (nth 4 definition
) t
))
284 (@ (language elisp falias
) make-falias
)
285 (function (lambda (&rest args
)
286 (apply (cdr (autoload-do-load definition symbol nil
)) args
)))
289 (@ (language elisp falias
) make-falias
)
290 (function (lambda (&rest args
)
291 (apply (autoload-do-load definition symbol nil
) args
)))
293 ((and (symbolp definition
)
294 (let ((fn (symbol-function definition
)))
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
)))))))
302 (@ (language elisp falias
) make-falias
)
303 (function (lambda (&rest args
) `(,definition
,@args
)))
306 (funcall (@ (language elisp falias
) make-falias
)
307 (function (lambda (&rest args
) (apply definition args
)))
312 (funcall (@ (system base compile
) compile-file
)
314 (funcall (@ (guile) symbol-
>keyword
) 'from
)
316 (funcall (@ (guile) symbol-
>keyword
) 'to
)
320 ;;; Equality predicates
322 (defun eql (obj1 obj2
)
324 (funcall (@ (guile) eqv?
) obj1 obj2
)
327 (defun equal (obj1 obj2
)
329 (funcall (@ (guile) equal?
) obj1 obj2
)
334 ;;; `symbolp' and `symbol-function' are defined above.
336 (fset 'symbol-name
(@ (guile) symbol-
>string
))
337 (fset 'symbol-value
(@ (language elisp runtime
) symbol-value
))
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?
))
343 (fset 'intern
(@ (guile) string-
>symbol
))
345 ;(defun defvaralias (new-alias base-variable &optional docstring)
346 ; (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
348 ; (funcall (@ (language elisp runtime) set-symbol-fluid!)
353 ;;; Numerical type predicates
355 (defun floatp (object)
356 (and (funcall (@ (guile) real?
) object
)
357 (or (funcall (@ (guile) inexact?
) object
)
358 (null (funcall (@ (guile) integer?
) object
)))))
360 (defun integerp (object)
361 (and (funcall (@ (guile) integer?
) object
)
362 (funcall (@ (guile) exact?
) object
)))
364 (defun numberp (object)
365 (funcall (@ (guile) real?
) object
))
367 (defun wholenump (object)
368 (and (integerp object
) (>= object
0)))
370 (defun zerop (object)
373 ;;; Numerical comparisons
375 (fset '= (@ (guile) =))
377 (defun /= (num1 num2
)
378 (null (= num1 num2
)))
380 (fset '< (@ (guile) <))
381 (fset '<= (@ (guile) <=))
382 (fset '> (@ (guile) >))
383 (fset '>= (@ (guile) >=))
385 (defun max (&rest numbers
)
386 (apply (@ (guile) max
) numbers
))
388 (defun min (&rest numbers
)
389 (apply (@ (guile) min
) numbers
))
391 ;;; Arithmetic functions
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
))
401 ;;; Floating-point rounding
403 (fset 'ffloor
(@ (guile) floor
))
404 (fset 'fceiling
(@ (guile) ceiling
))
405 (fset 'ftruncate
(@ (guile) truncate
))
406 (fset 'fround
(@ (guile) round
))
408 ;;; Numeric conversion
412 (funcall (@ (guile) exact-
>inexact
) arg
)
413 (signal 'wrong-type-argument
`(numberp ,arg
))))
420 (null (consp object
)))
422 (defun nlistp (object)
423 (null (listp object
)))
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
))
432 (fset 'nreverse
(@ (guile) reverse
!))
434 (defun car-safe (object)
439 (defun cdr-safe (object)
444 (defun setcar (cell newcar
)
447 (funcall (@ (guile) set-car
!) cell newcar
)
449 (signal 'wrong-type-argument
`(consp ,cell
))))
451 (defun setcdr (cell newcdr
)
454 (funcall (@ (guile) set-cdr
!) cell newcdr
)
456 (signal 'wrong-type-argument
`(consp ,cell
))))
458 (defun %member
(elt list test
)
462 (if (funcall test elt
(car list
))
464 (%member elt
(cdr list
) test
)))
465 (t (signal 'wrong-type-argument
`(listp ,list
)))))
467 (defun member (elt list
)
468 (%member elt list
#'equal
))
470 (defun memql (elt list
)
471 (%member elt list
#'eql
))
473 (defun memq (elt list
)
474 (%member elt list
#'eq
))
476 (defun assoc (key list
)
477 (funcall (@ (srfi srfi-1
) assoc
) key list
#'equal
))
479 (defun assq (key list
)
480 (funcall (@ (srfi srfi-1
) assoc
) key list
#'eq
))
482 (defun rplaca (cell newcar
)
483 (funcall (@ (guile) set-car
!) cell newcar
)
486 (defun rplacd (cell newcdr
)
487 (funcall (@ (guile) set-cdr
!) cell newcdr
)
502 (defmacro dolist
(spec &rest body
)
503 (apply #'(lambda (var list
&optional result
)
506 (cons 'lambda
(cons (list var
) body
))
513 (defun string (&rest characters
)
514 (funcall (@ (guile) list-
>string
)
515 (mapcar (@ (guile) integer-
>char
) characters
)))
517 (defun stringp (object)
518 (funcall (@ (guile) string?
) object
))
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
)))
525 (fset 'string
= 'string-equal
)
527 (defun substring (string from
&optional to
)
528 (apply (@ (guile) substring
) string from
(if to
(list to
) nil
)))
531 (funcall (@ (guile) string-upcase
) obj
))
533 (defun downcase (obj)
534 (funcall (@ (guile) string-downcase
) obj
))
536 (defun string-match (regexp string
&optional start
)
537 (let ((m (funcall (@ (ice-9 regex
) string-match
)
542 (funcall (@ (ice-9 regex
) match
:start
) m
0)
547 (defun make-vector (length init
)
548 (funcall (@ (guile) make-vector
) length init
))
552 (defun length (sequence)
553 (funcall (if (listp sequence
)
555 (@ (guile) generalized-vector-length
))
558 (defun mapcar (function sequence
)
559 (funcall (@ (guile) map
) function sequence
))
561 (defun mapc (function sequence
)
562 (funcall (@ (guile) for-each
) function sequence
)
565 (defun aref (array idx
)
566 (funcall (@ (guile) generalized-vector-ref
) array idx
))
568 (defun aset (array idx newelt
)
569 (funcall (@ (guile) generalized-vector-set
!) array idx newelt
)
572 (defun concat (&rest sequences
)
573 (apply (@ (guile) string-append
) sequences
))
577 (defun %plist-member
(plist property test
)
581 (if (funcall test
(car plist
) property
)
583 (%plist-member
(cdr (cdr plist
)) property test
)))
584 (t (signal 'wrong-type-argument
`(listp ,plist
)))))
586 (defun %plist-get
(plist property test
)
587 (car (%plist-member plist property test
)))
589 (defun %plist-put
(plist property value test
)
590 (let ((x (%plist-member plist property test
)))
592 (progn (setcar x value
) plist
)
593 (cons property
(cons value plist
)))))
595 (defun plist-get (plist property
)
596 (%plist-get plist property
#'eq
))
598 (defun plist-put (plist property value
)
599 (%plist-put plist property value
#'eq
))
601 (defun plist-member (plist property
)
602 (%plist-member plist property
#'eq
))
604 (defun lax-plist-get (plist property
)
605 (%plist-get plist property
#'equal
))
607 (defun lax-plist-put (plist property value
)
608 (%plist-put plist property value
#'equal
))
610 (defvar plist-function
(funcall (@ (guile) make-object-property
)))
612 (defun symbol-plist (symbol)
613 (funcall plist-function symbol
))
615 (defun setplist (symbol plist
)
616 (funcall (funcall (@ (guile) setter
) plist-function
) symbol plist
))
618 (defun get (symbol propname
)
619 (plist-get (symbol-plist symbol
) propname
))
621 (defun put (symbol propname value
)
622 (setplist symbol
(plist-put (symbol-plist symbol
) propname value
)))
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
))
635 (list (car handler
)))))
637 `(funcall (@ (guile) catch
)
639 #'(lambda () ,bodyform
)
640 #'(lambda (,key
,error-symbol
,data
)
641 (declare (lexical ,key
,error-symbol
,data
))
643 (get ,error-symbol
'error-conditions
))
645 `((,var
(cons ,error-symbol
,data
)))
647 (declare (lexical ,conditions
648 ,@(if var
`(,var
) '())))
649 (cond ,@(mapcar #'handler-
>cond-clause handlers
)
650 (t (signal ,error-symbol
,data
)))))))))
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
))
656 (put 'throw
'error-conditions
'(throw))
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
))
665 (declare (lexical ,tag-value
))
670 (let ((,data
(cdr ,c
)))
671 (declare (lexical ,data
))
672 (if (eq (car ,data
) ,tag-value
)
674 (apply #'throw
,data
))))))))
676 (defun throw (tag value
)
677 (signal (if %catch
'throw
'no-catch
) (list tag value
)))
681 (defun princ (object)
682 (funcall (@ (guile) display
) object
))
684 (defun print (object)
685 (funcall (@ (guile) write
) object
))
687 (defun prin1 (object)
688 (funcall (@ (guile) write
) object
))
691 (funcall (@ (guile) newline
)))
693 (defun format* (stream string
&rest args
)
694 (apply (@ (guile) format
) stream string args
))
696 (defun send-string-to-terminal (string)
699 (defun read-from-minibuffer (prompt &rest ignore
)
701 (let ((value (funcall (@ (ice-9 rdelim
) read-line
))))
702 (if (funcall (@ (guile) eof-object?
) value
)
706 (defun prin1-to-string (object)
707 (format* nil
"~S" object
))
709 ;; Random number generation
711 (defvar %random-state
(funcall (@ (guile) copy-random-state
)
712 (@ (guile) *random-state
*)))
714 (defun random (&optional limit
)
717 (funcall (@ (guile) random-state-from-platform
))))
718 (funcall (@ (guile) random
)
719 (if (wholenump limit
)
721 (@ (guile) most-positive-fixnum
))
724 (defmacro save-excursion
(&rest body
)
725 `(call-with-save-excursion #'(lambda () ,@body
)))
727 (defmacro save-current-buffer
(&rest body
)
728 `(call-with-save-current-buffer #'(lambda () ,@body
)))
730 (defmacro save-restriction
(&rest body
)
731 `(call-with-save-restriction #'(lambda () ,@body
)))
733 (defmacro track-mouse
(&rest body
)
734 `(call-with-track-mouse #'(lambda () ,@body
)))
736 (defmacro setq-default
(var value
&rest args
)
737 `(progn (set-default ',var
,value
)
740 `(setq-default ,@args
))))
742 (defmacro catch
(tag &rest body
)
743 `(call-with-catch ,tag
#'(lambda () ,@body
)))
745 (defmacro condition-case
(var bodyform
&rest 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
753 #'(lambda () ,@handler-body
)
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
))
767 (args (funcall (@ (guile) frame-arguments
) frame
)))
768 (cons t
(cons pname args
))))
770 (defun guile-backtrace (&rest args
)
772 (let* ((stack (apply (@ (guile) make-stack
) t args
))
773 (frame (funcall (@ (guile) stack-ref
) stack
1))
774 (space (funcall (@ (guile) integer-
>char
) 32)))
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
))
781 (prin1 (funcall (@ (guile) frame-arguments
) frame
))
783 (setq frame
(funcall (@ (guile) frame-previous
) frame
)))
789 (defun %set-eager-macroexpansion-mode
(ignore)
792 (%define-compiler-macro require
(form)
793 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
794 (funcall #'require
,@(cdr form
))))