diff options
Diffstat (limited to 'module/language/elisp/boot.el')
-rw-r--r-- | module/language/elisp/boot.el | 617 |
1 files changed, 617 insertions, 0 deletions
diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el new file mode 100644 index 000000000..f55722a9a --- /dev/null +++ b/module/language/elisp/boot.el @@ -0,0 +1,617 @@ +;;; 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)) |