mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
* module/language/elisp/boot.el (length): Use `length' if the argument is a list or `generalized-vector-length' otherwise.
617 lines
17 KiB
EmacsLisp
617 lines
17 KiB
EmacsLisp
;;; Guile Emacs Lisp -*- lexical-binding: t -*-
|
|
|
|
;;; Copyright (C) 2011 Free Software Foundation, Inc.
|
|
|
|
;;; This library is free software; you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU Lesser General Public License as
|
|
;;; published by the Free Software Foundation; either version 3 of the
|
|
;;; License, or (at your option) any later version.
|
|
;;;
|
|
;;; This library is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; Lesser General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU Lesser General Public
|
|
;;; License along with this library; if not, write to the Free Software
|
|
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
|
;;; 02110-1301 USA
|
|
|
|
;;; Code:
|
|
|
|
(defmacro @ (module symbol)
|
|
`(guile-ref ,module ,symbol))
|
|
|
|
(defmacro eval-and-compile (&rest body)
|
|
`(progn
|
|
(eval-when-compile ,@body)
|
|
(progn ,@body)))
|
|
|
|
(eval-and-compile
|
|
(defun null (object)
|
|
(if object nil t))
|
|
(defun consp (object)
|
|
(%funcall (@ (guile) pair?) object))
|
|
(defun listp (object)
|
|
(if object (consp object) t))
|
|
(defun car (list)
|
|
(if list (%funcall (@ (guile) car) list) nil))
|
|
(defun cdr (list)
|
|
(if list (%funcall (@ (guile) cdr) list) nil))
|
|
(defun make-symbol (name)
|
|
(%funcall (@ (guile) make-symbol) name))
|
|
(defun signal (error-symbol data)
|
|
(%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
|
|
|
|
(defmacro lambda (&rest cdr)
|
|
`#'(lambda ,@cdr))
|
|
|
|
(defmacro prog1 (first &rest body)
|
|
(let ((temp (make-symbol "prog1-temp")))
|
|
`(let ((,temp ,first))
|
|
(declare (lexical ,temp))
|
|
,@body
|
|
,temp)))
|
|
|
|
(defmacro prog2 (form1 form2 &rest body)
|
|
`(progn ,form1 (prog1 ,form2 ,@body)))
|
|
|
|
(defmacro cond (&rest clauses)
|
|
(if (null clauses)
|
|
nil
|
|
(let ((first (car clauses))
|
|
(rest (cdr clauses)))
|
|
(if (listp first)
|
|
(let ((condition (car first))
|
|
(body (cdr first)))
|
|
(if (null body)
|
|
(let ((temp (make-symbol "cond-temp")))
|
|
`(let ((,temp ,condition))
|
|
(declare (lexical ,temp))
|
|
(if ,temp
|
|
,temp
|
|
(cond ,@rest))))
|
|
`(if ,condition
|
|
(progn ,@body)
|
|
(cond ,@rest))))
|
|
(signal 'wrong-type-argument `(listp ,first))))))
|
|
|
|
(defmacro and (&rest conditions)
|
|
(cond ((null conditions) t)
|
|
((null (cdr conditions)) (car conditions))
|
|
(t `(if ,(car conditions)
|
|
(and ,@(cdr conditions))
|
|
nil))))
|
|
|
|
(defmacro or (&rest conditions)
|
|
(cond ((null conditions) nil)
|
|
((null (cdr conditions)) (car conditions))
|
|
(t (let ((temp (make-symbol "or-temp")))
|
|
`(let ((,temp ,(car conditions)))
|
|
(declare (lexical ,temp))
|
|
(if ,temp
|
|
,temp
|
|
(or ,@(cdr conditions))))))))
|
|
|
|
(defmacro lexical-let (bindings &rest body)
|
|
(labels ((loop (list vars)
|
|
(if (null list)
|
|
`(let ,bindings
|
|
(declare (lexical ,@vars))
|
|
,@body)
|
|
(loop (cdr list)
|
|
(if (consp (car list))
|
|
`(,(car (car list)) ,@vars)
|
|
`(,(car list) ,@vars))))))
|
|
(loop bindings '())))
|
|
|
|
(defmacro lexical-let* (bindings &rest body)
|
|
(labels ((loop (list vars)
|
|
(if (null list)
|
|
`(let* ,bindings
|
|
(declare (lexical ,@vars))
|
|
,@body)
|
|
(loop (cdr list)
|
|
(if (consp (car list))
|
|
(cons (car (car list)) vars)
|
|
(cons (car list) vars))))))
|
|
(loop bindings '())))
|
|
|
|
(defmacro while (test &rest body)
|
|
(let ((loop (make-symbol "loop")))
|
|
`(labels ((,loop ()
|
|
(if ,test
|
|
(progn ,@body (,loop))
|
|
nil)))
|
|
(,loop))))
|
|
|
|
(defmacro unwind-protect (bodyform &rest unwindforms)
|
|
`(funcall (@ (guile) dynamic-wind)
|
|
#'(lambda () nil)
|
|
#'(lambda () ,bodyform)
|
|
#'(lambda () ,@unwindforms)))
|
|
|
|
(defmacro when (cond &rest body)
|
|
`(if ,cond
|
|
(progn ,@body)))
|
|
|
|
(defmacro unless (cond &rest body)
|
|
`(when (not ,cond)
|
|
,@body))
|
|
|
|
(defun symbolp (object)
|
|
(%funcall (@ (guile) symbol?) object))
|
|
|
|
(defun functionp (object)
|
|
(%funcall (@ (guile) procedure?) object))
|
|
|
|
(defun symbol-function (symbol)
|
|
(let ((f (%funcall (@ (language elisp runtime) symbol-function)
|
|
symbol)))
|
|
(if (%funcall (@ (language elisp falias) falias?) f)
|
|
(%funcall (@ (language elisp falias) falias-object) f)
|
|
f)))
|
|
|
|
(defun eval (form)
|
|
(%funcall (@ (system base compile) compile)
|
|
form
|
|
(%funcall (@ (guile) symbol->keyword) 'from)
|
|
'elisp
|
|
(%funcall (@ (guile) symbol->keyword) 'to)
|
|
'value))
|
|
|
|
(defun %indirect-function (object)
|
|
(cond
|
|
((functionp object)
|
|
object)
|
|
((symbolp object) ;++ cycle detection
|
|
(%indirect-function (symbol-function object)))
|
|
((listp object)
|
|
(eval `(function ,object)))
|
|
(t
|
|
(signal 'invalid-function `(,object)))))
|
|
|
|
(defun apply (function &rest arguments)
|
|
(%funcall (@ (guile) apply)
|
|
(@ (guile) apply)
|
|
(%indirect-function function)
|
|
arguments))
|
|
|
|
(defun funcall (function &rest arguments)
|
|
(%funcall (@ (guile) apply)
|
|
(%indirect-function function)
|
|
arguments))
|
|
|
|
(defun fset (symbol definition)
|
|
(funcall (@ (language elisp runtime) set-symbol-function!)
|
|
symbol
|
|
(if (functionp definition)
|
|
definition
|
|
(funcall (@ (language elisp falias) make-falias)
|
|
#'(lambda (&rest args) (apply definition args))
|
|
definition)))
|
|
definition)
|
|
|
|
(defun load (file)
|
|
(funcall (@ (system base compile) compile-file)
|
|
file
|
|
(funcall (@ (guile) symbol->keyword) 'from)
|
|
'elisp
|
|
(funcall (@ (guile) symbol->keyword) 'to)
|
|
'value)
|
|
t)
|
|
|
|
;;; Equality predicates
|
|
|
|
(defun eq (obj1 obj2)
|
|
(if obj1
|
|
(funcall (@ (guile) eq?) obj1 obj2)
|
|
(null obj2)))
|
|
|
|
(defun eql (obj1 obj2)
|
|
(if obj1
|
|
(funcall (@ (guile) eqv?) obj1 obj2)
|
|
(null obj2)))
|
|
|
|
(defun equal (obj1 obj2)
|
|
(if obj1
|
|
(funcall (@ (guile) equal?) obj1 obj2)
|
|
(null obj2)))
|
|
|
|
;;; Symbols
|
|
|
|
;;; `symbolp' and `symbol-function' are defined above.
|
|
|
|
(fset 'symbol-name (@ (guile) symbol->string))
|
|
(fset 'symbol-value (@ (language elisp runtime) symbol-value))
|
|
(fset 'set (@ (language elisp runtime) set-symbol-value!))
|
|
(fset 'makunbound (@ (language elisp runtime) makunbound!))
|
|
(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
|
|
(fset 'boundp (@ (language elisp runtime) symbol-bound?))
|
|
(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
|
|
(fset 'intern (@ (guile) string->symbol))
|
|
|
|
(defun defvaralias (new-alias base-variable &optional docstring)
|
|
(let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
|
|
base-variable)))
|
|
(funcall (@ (language elisp runtime) set-symbol-fluid!)
|
|
new-alias
|
|
fluid)
|
|
base-variable))
|
|
|
|
;;; Numerical type predicates
|
|
|
|
(defun floatp (object)
|
|
(and (funcall (@ (guile) real?) object)
|
|
(or (funcall (@ (guile) inexact?) object)
|
|
(null (funcall (@ (guile) integer?) object)))))
|
|
|
|
(defun integerp (object)
|
|
(and (funcall (@ (guile) integer?) object)
|
|
(funcall (@ (guile) exact?) object)))
|
|
|
|
(defun numberp (object)
|
|
(funcall (@ (guile) real?) object))
|
|
|
|
(defun wholenump (object)
|
|
(and (integerp object) (>= object 0)))
|
|
|
|
(defun zerop (object)
|
|
(= object 0))
|
|
|
|
;;; Numerical comparisons
|
|
|
|
(fset '= (@ (guile) =))
|
|
|
|
(defun /= (num1 num2)
|
|
(null (= num1 num2)))
|
|
|
|
(fset '< (@ (guile) <))
|
|
(fset '<= (@ (guile) <=))
|
|
(fset '> (@ (guile) >))
|
|
(fset '>= (@ (guile) >=))
|
|
|
|
(defun max (&rest numbers)
|
|
(apply (@ (guile) max) numbers))
|
|
|
|
(defun min (&rest numbers)
|
|
(apply (@ (guile) min) numbers))
|
|
|
|
;;; Arithmetic functions
|
|
|
|
(fset '1+ (@ (guile) 1+))
|
|
(fset '1- (@ (guile) 1-))
|
|
(fset '+ (@ (guile) +))
|
|
(fset '- (@ (guile) -))
|
|
(fset '* (@ (guile) *))
|
|
(fset '% (@ (guile) modulo))
|
|
(fset 'abs (@ (guile) abs))
|
|
|
|
;;; Floating-point rounding
|
|
|
|
(fset 'ffloor (@ (guile) floor))
|
|
(fset 'fceiling (@ (guile) ceiling))
|
|
(fset 'ftruncate (@ (guile) truncate))
|
|
(fset 'fround (@ (guile) round))
|
|
|
|
;;; Numeric conversion
|
|
|
|
(defun float (arg)
|
|
(if (numberp arg)
|
|
(funcall (@ (guile) exact->inexact) arg)
|
|
(signal 'wrong-type-argument `(numberp ,arg))))
|
|
|
|
;;; List predicates
|
|
|
|
(fset 'not #'null)
|
|
|
|
(defun atom (object)
|
|
(null (consp object)))
|
|
|
|
(defun nlistp (object)
|
|
(null (listp object)))
|
|
|
|
;;; Lists
|
|
|
|
(fset 'cons (@ (guile) cons))
|
|
(fset 'list (@ (guile) list))
|
|
(fset 'make-list (@ (guile) make-list))
|
|
(fset 'append (@ (guile) append))
|
|
(fset 'reverse (@ (guile) reverse))
|
|
(fset 'nreverse (@ (guile) reverse!))
|
|
|
|
(defun car-safe (object)
|
|
(if (consp object)
|
|
(car object)
|
|
nil))
|
|
|
|
(defun cdr-safe (object)
|
|
(if (consp object)
|
|
(cdr object)
|
|
nil))
|
|
|
|
(defun setcar (cell newcar)
|
|
(if (consp cell)
|
|
(progn
|
|
(funcall (@ (guile) set-car!) cell newcar)
|
|
newcar)
|
|
(signal 'wrong-type-argument `(consp ,cell))))
|
|
|
|
(defun setcdr (cell newcdr)
|
|
(if (consp cell)
|
|
(progn
|
|
(funcall (@ (guile) set-cdr!) cell newcdr)
|
|
newcdr)
|
|
(signal 'wrong-type-argument `(consp ,cell))))
|
|
|
|
(defun nthcdr (n list)
|
|
(let ((i 0))
|
|
(while (< i n)
|
|
(setq list (cdr list)
|
|
i (+ i 1)))
|
|
list))
|
|
|
|
(defun nth (n list)
|
|
(car (nthcdr n list)))
|
|
|
|
(defun %member (elt list test)
|
|
(cond
|
|
((null list) nil)
|
|
((consp list)
|
|
(if (funcall test elt (car list))
|
|
list
|
|
(%member elt (cdr list) test)))
|
|
(t (signal 'wrong-type-argument `(listp ,list)))))
|
|
|
|
(defun member (elt list)
|
|
(%member elt list #'equal))
|
|
|
|
(defun memql (elt list)
|
|
(%member elt list #'eql))
|
|
|
|
(defun memq (elt list)
|
|
(%member elt list #'eq))
|
|
|
|
(defun assoc (key list)
|
|
(funcall (@ (srfi srfi-1) assoc) key list #'equal))
|
|
|
|
(defun assq (key list)
|
|
(funcall (@ (srfi srfi-1) assoc) key list #'eq))
|
|
|
|
(defun rplaca (cell newcar)
|
|
(funcall (@ (guile) set-car!) cell newcar)
|
|
newcar)
|
|
|
|
(defun rplacd (cell newcdr)
|
|
(funcall (@ (guile) set-cdr!) cell newcdr)
|
|
newcdr)
|
|
|
|
(defun caar (x)
|
|
(car (car x)))
|
|
|
|
(defun cadr (x)
|
|
(car (cdr x)))
|
|
|
|
(defun cdar (x)
|
|
(cdr (car x)))
|
|
|
|
(defun cddr (x)
|
|
(cdr (cdr x)))
|
|
|
|
(defmacro dolist (spec &rest body)
|
|
(apply #'(lambda (var list &optional result)
|
|
`(mapc #'(lambda (,var)
|
|
,@body
|
|
,result)
|
|
,list))
|
|
spec))
|
|
|
|
;;; Strings
|
|
|
|
(defun string (&rest characters)
|
|
(funcall (@ (guile) list->string)
|
|
(mapcar (@ (guile) integer->char) characters)))
|
|
|
|
(defun stringp (object)
|
|
(funcall (@ (guile) string?) object))
|
|
|
|
(defun string-equal (s1 s2)
|
|
(let ((s1 (if (symbolp s1) (symbol-name s1) s1))
|
|
(s2 (if (symbolp s2) (symbol-name s2) s2)))
|
|
(funcall (@ (guile) string=?) s1 s2)))
|
|
|
|
(fset 'string= 'string-equal)
|
|
|
|
(defun substring (string from &optional to)
|
|
(apply (@ (guile) substring) string from (if to (list to) nil)))
|
|
|
|
(defun upcase (obj)
|
|
(funcall (@ (guile) string-upcase) obj))
|
|
|
|
(defun downcase (obj)
|
|
(funcall (@ (guile) string-downcase) obj))
|
|
|
|
(defun string-match (regexp string &optional start)
|
|
(let ((m (funcall (@ (ice-9 regex) string-match)
|
|
regexp
|
|
string
|
|
(or start 0))))
|
|
(if m
|
|
(funcall (@ (ice-9 regex) match:start) m 0)
|
|
nil)))
|
|
|
|
;; Vectors
|
|
|
|
(defun make-vector (length init)
|
|
(funcall (@ (guile) make-vector) length init))
|
|
|
|
;;; Sequences
|
|
|
|
(defun length (sequence)
|
|
(funcall (if (listp sequence)
|
|
(@ (guile) length)
|
|
(@ (guile) generalized-vector-length))
|
|
sequence))
|
|
|
|
(defun mapcar (function sequence)
|
|
(funcall (@ (guile) map) function sequence))
|
|
|
|
(defun mapc (function sequence)
|
|
(funcall (@ (guile) for-each) function sequence)
|
|
sequence)
|
|
|
|
(defun aref (array idx)
|
|
(funcall (@ (guile) generalized-vector-ref) array idx))
|
|
|
|
(defun aset (array idx newelt)
|
|
(funcall (@ (guile) generalized-vector-set!) array idx newelt)
|
|
newelt)
|
|
|
|
(defun concat (&rest sequences)
|
|
(apply (@ (guile) string-append) sequences))
|
|
|
|
;;; Property lists
|
|
|
|
(defun %plist-member (plist property test)
|
|
(cond
|
|
((null plist) nil)
|
|
((consp plist)
|
|
(if (funcall test (car plist) property)
|
|
(cdr plist)
|
|
(%plist-member (cdr (cdr plist)) property test)))
|
|
(t (signal 'wrong-type-argument `(listp ,plist)))))
|
|
|
|
(defun %plist-get (plist property test)
|
|
(car (%plist-member plist property test)))
|
|
|
|
(defun %plist-put (plist property value test)
|
|
(let ((x (%plist-member plist property test)))
|
|
(if x
|
|
(progn (setcar x value) plist)
|
|
(cons property (cons value plist)))))
|
|
|
|
(defun plist-get (plist property)
|
|
(%plist-get plist property #'eq))
|
|
|
|
(defun plist-put (plist property value)
|
|
(%plist-put plist property value #'eq))
|
|
|
|
(defun plist-member (plist property)
|
|
(%plist-member plist property #'eq))
|
|
|
|
(defun lax-plist-get (plist property)
|
|
(%plist-get plist property #'equal))
|
|
|
|
(defun lax-plist-put (plist property value)
|
|
(%plist-put plist property value #'equal))
|
|
|
|
(defvar plist-function (funcall (@ (guile) make-object-property)))
|
|
|
|
(defun symbol-plist (symbol)
|
|
(funcall plist-function symbol))
|
|
|
|
(defun setplist (symbol plist)
|
|
(funcall (funcall (@ (guile) setter) plist-function) symbol plist))
|
|
|
|
(defun get (symbol propname)
|
|
(plist-get (symbol-plist symbol) propname))
|
|
|
|
(defun put (symbol propname value)
|
|
(setplist symbol (plist-put (symbol-plist symbol) propname value)))
|
|
|
|
;;; Nonlocal exits
|
|
|
|
(defmacro condition-case (var bodyform &rest handlers)
|
|
(let ((key (make-symbol "key"))
|
|
(error-symbol (make-symbol "error-symbol"))
|
|
(data (make-symbol "data"))
|
|
(conditions (make-symbol "conditions")))
|
|
(flet ((handler->cond-clause (handler)
|
|
`((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
|
|
(if (consp (car handler))
|
|
(car handler)
|
|
(list (car handler)))))
|
|
,@(cdr handler))))
|
|
`(funcall (@ (guile) catch)
|
|
'elisp-condition
|
|
#'(lambda () ,bodyform)
|
|
#'(lambda (,key ,error-symbol ,data)
|
|
(declare (lexical ,key ,error-symbol ,data))
|
|
(let ((,conditions
|
|
(get ,error-symbol 'error-conditions))
|
|
,@(if var
|
|
`((,var (cons ,error-symbol ,data)))
|
|
'()))
|
|
(declare (lexical ,conditions
|
|
,@(if var `(,var) '())))
|
|
(cond ,@(mapcar #'handler->cond-clause handlers)
|
|
(t (signal ,error-symbol ,data)))))))))
|
|
|
|
(put 'error 'error-conditions '(error))
|
|
(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
|
|
(put 'invalid-function 'error-conditions '(invalid-function error))
|
|
(put 'no-catch 'error-conditions '(no-catch error))
|
|
(put 'throw 'error-conditions '(throw))
|
|
|
|
(defvar %catch nil)
|
|
|
|
(defmacro catch (tag &rest body)
|
|
(let ((tag-value (make-symbol "tag-value"))
|
|
(c (make-symbol "c"))
|
|
(data (make-symbol "data")))
|
|
`(let ((,tag-value ,tag))
|
|
(declare (lexical ,tag-value))
|
|
(condition-case ,c
|
|
(let ((%catch t))
|
|
,@body)
|
|
(throw
|
|
(let ((,data (cdr ,c)))
|
|
(declare (lexical ,data))
|
|
(if (eq (car ,data) ,tag-value)
|
|
(car (cdr ,data))
|
|
(apply #'throw ,data))))))))
|
|
|
|
(defun throw (tag value)
|
|
(signal (if %catch 'throw 'no-catch) (list tag value)))
|
|
|
|
;;; I/O
|
|
|
|
(defun princ (object)
|
|
(funcall (@ (guile) display) object))
|
|
|
|
(defun print (object)
|
|
(funcall (@ (guile) write) object))
|
|
|
|
(defun terpri ()
|
|
(funcall (@ (guile) newline)))
|
|
|
|
(defun format* (stream string &rest args)
|
|
(apply (@ (guile) format) stream string args))
|
|
|
|
(defun send-string-to-terminal (string)
|
|
(princ string))
|
|
|
|
(defun read-from-minibuffer (prompt &rest ignore)
|
|
(princ prompt)
|
|
(let ((value (funcall (@ (ice-9 rdelim) read-line))))
|
|
(if (funcall (@ (guile) eof-object?) value)
|
|
""
|
|
value)))
|
|
|
|
(defun prin1-to-string (object)
|
|
(format* nil "~S" object))
|
|
|
|
;; Random number generation
|
|
|
|
(defvar %random-state (funcall (@ (guile) copy-random-state)
|
|
(@ (guile) *random-state*)))
|
|
|
|
(defun random (&optional limit)
|
|
(if (eq limit t)
|
|
(setq %random-state
|
|
(funcall (@ (guile) random-state-from-platform))))
|
|
(funcall (@ (guile) random)
|
|
(if (wholenump limit)
|
|
limit
|
|
(@ (guile) most-positive-fixnum))
|
|
%random-state))
|