boot.el 17 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618
  1. ;;; Guile Emacs Lisp -*- lexical-binding: t -*-
  2. ;;; Copyright (C) 2011 Free Software Foundation, Inc.
  3. ;;; This library is free software; you can redistribute it and/or modify
  4. ;;; it under the terms of the GNU Lesser General Public License as
  5. ;;; published by the Free Software Foundation; either version 3 of the
  6. ;;; License, or (at your option) any later version.
  7. ;;;
  8. ;;; This library is distributed in the hope that it will be useful, but
  9. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;; Lesser General Public License for more details.
  12. ;;;
  13. ;;; You should have received a copy of the GNU Lesser General Public
  14. ;;; License along with this library; if not, write to the Free Software
  15. ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16. ;;; 02110-1301 USA
  17. ;;; Code:
  18. (defmacro @ (module symbol)
  19. `(guile-ref ,module ,symbol))
  20. (defmacro eval-and-compile (&rest body)
  21. `(progn
  22. (eval-when-compile ,@body)
  23. (progn ,@body)))
  24. (eval-and-compile
  25. (defun null (object)
  26. (if object nil t))
  27. (defun consp (object)
  28. (%funcall (@ (guile) pair?) object))
  29. (defun listp (object)
  30. (if object (consp object) t))
  31. (defun car (list)
  32. (if list (%funcall (@ (guile) car) list) nil))
  33. (defun cdr (list)
  34. (if list (%funcall (@ (guile) cdr) list) nil))
  35. (defun make-symbol (name)
  36. (%funcall (@ (guile) make-symbol) name))
  37. (defun signal (error-symbol data)
  38. (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
  39. (defmacro lambda (&rest cdr)
  40. `#'(lambda ,@cdr))
  41. (defmacro prog1 (first &rest body)
  42. (let ((temp (make-symbol "prog1-temp")))
  43. `(let ((,temp ,first))
  44. (declare (lexical ,temp))
  45. ,@body
  46. ,temp)))
  47. (defmacro prog2 (form1 form2 &rest body)
  48. `(progn ,form1 (prog1 ,form2 ,@body)))
  49. (defmacro cond (&rest clauses)
  50. (if (null clauses)
  51. nil
  52. (let ((first (car clauses))
  53. (rest (cdr clauses)))
  54. (if (listp first)
  55. (let ((condition (car first))
  56. (body (cdr first)))
  57. (if (null body)
  58. (let ((temp (make-symbol "cond-temp")))
  59. `(let ((,temp ,condition))
  60. (declare (lexical ,temp))
  61. (if ,temp
  62. ,temp
  63. (cond ,@rest))))
  64. `(if ,condition
  65. (progn ,@body)
  66. (cond ,@rest))))
  67. (signal 'wrong-type-argument `(listp ,first))))))
  68. (defmacro and (&rest conditions)
  69. (cond ((null conditions) t)
  70. ((null (cdr conditions)) (car conditions))
  71. (t `(if ,(car conditions)
  72. (and ,@(cdr conditions))
  73. nil))))
  74. (defmacro or (&rest conditions)
  75. (cond ((null conditions) nil)
  76. ((null (cdr conditions)) (car conditions))
  77. (t (let ((temp (make-symbol "or-temp")))
  78. `(let ((,temp ,(car conditions)))
  79. (declare (lexical ,temp))
  80. (if ,temp
  81. ,temp
  82. (or ,@(cdr conditions))))))))
  83. (defmacro lexical-let (bindings &rest body)
  84. (labels ((loop (list vars)
  85. (if (null list)
  86. `(let ,bindings
  87. (declare (lexical ,@vars))
  88. ,@body)
  89. (loop (cdr list)
  90. (if (consp (car list))
  91. `(,(car (car list)) ,@vars)
  92. `(,(car list) ,@vars))))))
  93. (loop bindings '())))
  94. (defmacro lexical-let* (bindings &rest body)
  95. (labels ((loop (list vars)
  96. (if (null list)
  97. `(let* ,bindings
  98. (declare (lexical ,@vars))
  99. ,@body)
  100. (loop (cdr list)
  101. (if (consp (car list))
  102. (cons (car (car list)) vars)
  103. (cons (car list) vars))))))
  104. (loop bindings '())))
  105. (defmacro while (test &rest body)
  106. (let ((loop (make-symbol "loop")))
  107. `(labels ((,loop ()
  108. (if ,test
  109. (progn ,@body (,loop))
  110. nil)))
  111. (,loop))))
  112. (defmacro unwind-protect (bodyform &rest unwindforms)
  113. `(funcall (@ (guile) dynamic-wind)
  114. #'(lambda () nil)
  115. #'(lambda () ,bodyform)
  116. #'(lambda () ,@unwindforms)))
  117. (defmacro when (cond &rest body)
  118. `(if ,cond
  119. (progn ,@body)))
  120. (defmacro unless (cond &rest body)
  121. `(when (not ,cond)
  122. ,@body))
  123. (defun symbolp (object)
  124. (%funcall (@ (guile) symbol?) object))
  125. (defun functionp (object)
  126. (%funcall (@ (guile) procedure?) object))
  127. (defun symbol-function (symbol)
  128. (let ((f (%funcall (@ (language elisp runtime) symbol-function)
  129. symbol)))
  130. (if (%funcall (@ (language elisp falias) falias?) f)
  131. (%funcall (@ (language elisp falias) falias-object) f)
  132. f)))
  133. (defun eval (form)
  134. (%funcall (@ (system base compile) compile)
  135. form
  136. (%funcall (@ (guile) symbol->keyword) 'from)
  137. 'elisp
  138. (%funcall (@ (guile) symbol->keyword) 'to)
  139. 'value))
  140. (defun %indirect-function (object)
  141. (cond
  142. ((functionp object)
  143. object)
  144. ((symbolp object) ;++ cycle detection
  145. (%indirect-function (symbol-function object)))
  146. ((listp object)
  147. (eval `(function ,object)))
  148. (t
  149. (signal 'invalid-function `(,object)))))
  150. (defun apply (function &rest arguments)
  151. (%funcall (@ (guile) apply)
  152. (@ (guile) apply)
  153. (%indirect-function function)
  154. arguments))
  155. (defun funcall (function &rest arguments)
  156. (%funcall (@ (guile) apply)
  157. (%indirect-function function)
  158. arguments))
  159. (defun fset (symbol definition)
  160. (funcall (@ (language elisp runtime) set-symbol-function!)
  161. symbol
  162. (if (functionp definition)
  163. definition
  164. (funcall (@ (language elisp falias) make-falias)
  165. #'(lambda (&rest args) (apply definition args))
  166. definition)))
  167. definition)
  168. (defun load (file)
  169. (funcall (@ (system base compile) compile-file)
  170. file
  171. (funcall (@ (guile) symbol->keyword) 'from)
  172. 'elisp
  173. (funcall (@ (guile) symbol->keyword) 'to)
  174. 'value)
  175. t)
  176. ;;; Equality predicates
  177. (defun eq (obj1 obj2)
  178. (if obj1
  179. (funcall (@ (guile) eq?) obj1 obj2)
  180. (null obj2)))
  181. (defun eql (obj1 obj2)
  182. (if obj1
  183. (funcall (@ (guile) eqv?) obj1 obj2)
  184. (null obj2)))
  185. (defun equal (obj1 obj2)
  186. (if obj1
  187. (funcall (@ (guile) equal?) obj1 obj2)
  188. (null obj2)))
  189. ;;; Symbols
  190. ;;; `symbolp' and `symbol-function' are defined above.
  191. (fset 'symbol-name (@ (guile) symbol->string))
  192. (fset 'symbol-value (@ (language elisp runtime) symbol-value))
  193. (fset 'set (@ (language elisp runtime) set-symbol-value!))
  194. (fset 'makunbound (@ (language elisp runtime) makunbound!))
  195. (fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
  196. (fset 'boundp (@ (language elisp runtime) symbol-bound?))
  197. (fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
  198. (fset 'intern (@ (guile) string->symbol))
  199. (defun defvaralias (new-alias base-variable &optional docstring)
  200. (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
  201. base-variable)))
  202. (funcall (@ (language elisp runtime) set-symbol-fluid!)
  203. new-alias
  204. fluid)
  205. base-variable))
  206. ;;; Numerical type predicates
  207. (defun floatp (object)
  208. (and (funcall (@ (guile) real?) object)
  209. (or (funcall (@ (guile) inexact?) object)
  210. (null (funcall (@ (guile) integer?) object)))))
  211. (defun integerp (object)
  212. (and (funcall (@ (guile) integer?) object)
  213. (funcall (@ (guile) exact?) object)))
  214. (defun numberp (object)
  215. (funcall (@ (guile) real?) object))
  216. (defun wholenump (object)
  217. (and (integerp object) (>= object 0)))
  218. (defun zerop (object)
  219. (= object 0))
  220. ;;; Numerical comparisons
  221. (fset '= (@ (guile) =))
  222. (defun /= (num1 num2)
  223. (null (= num1 num2)))
  224. (fset '< (@ (guile) <))
  225. (fset '<= (@ (guile) <=))
  226. (fset '> (@ (guile) >))
  227. (fset '>= (@ (guile) >=))
  228. (defun max (&rest numbers)
  229. (apply (@ (guile) max) numbers))
  230. (defun min (&rest numbers)
  231. (apply (@ (guile) min) numbers))
  232. ;;; Arithmetic functions
  233. (fset '1+ (@ (guile) 1+))
  234. (fset '1- (@ (guile) 1-))
  235. (fset '+ (@ (guile) +))
  236. (fset '- (@ (guile) -))
  237. (fset '* (@ (guile) *))
  238. (fset '% (@ (guile) modulo))
  239. (fset 'abs (@ (guile) abs))
  240. ;;; Floating-point rounding
  241. (fset 'ffloor (@ (guile) floor))
  242. (fset 'fceiling (@ (guile) ceiling))
  243. (fset 'ftruncate (@ (guile) truncate))
  244. (fset 'fround (@ (guile) round))
  245. ;;; Numeric conversion
  246. (defun float (arg)
  247. (if (numberp arg)
  248. (funcall (@ (guile) exact->inexact) arg)
  249. (signal 'wrong-type-argument `(numberp ,arg))))
  250. ;;; List predicates
  251. (fset 'not #'null)
  252. (defun atom (object)
  253. (null (consp object)))
  254. (defun nlistp (object)
  255. (null (listp object)))
  256. ;;; Lists
  257. (fset 'cons (@ (guile) cons))
  258. (fset 'list (@ (guile) list))
  259. (fset 'make-list (@ (guile) make-list))
  260. (fset 'append (@ (guile) append))
  261. (fset 'reverse (@ (guile) reverse))
  262. (fset 'nreverse (@ (guile) reverse!))
  263. (defun car-safe (object)
  264. (if (consp object)
  265. (car object)
  266. nil))
  267. (defun cdr-safe (object)
  268. (if (consp object)
  269. (cdr object)
  270. nil))
  271. (defun setcar (cell newcar)
  272. (if (consp cell)
  273. (progn
  274. (funcall (@ (guile) set-car!) cell newcar)
  275. newcar)
  276. (signal 'wrong-type-argument `(consp ,cell))))
  277. (defun setcdr (cell newcdr)
  278. (if (consp cell)
  279. (progn
  280. (funcall (@ (guile) set-cdr!) cell newcdr)
  281. newcdr)
  282. (signal 'wrong-type-argument `(consp ,cell))))
  283. (defun nthcdr (n list)
  284. (let ((i 0))
  285. (while (< i n)
  286. (setq list (cdr list)
  287. i (+ i 1)))
  288. list))
  289. (defun nth (n list)
  290. (car (nthcdr n list)))
  291. (defun %member (elt list test)
  292. (cond
  293. ((null list) nil)
  294. ((consp list)
  295. (if (funcall test elt (car list))
  296. list
  297. (%member elt (cdr list) test)))
  298. (t (signal 'wrong-type-argument `(listp ,list)))))
  299. (defun member (elt list)
  300. (%member elt list #'equal))
  301. (defun memql (elt list)
  302. (%member elt list #'eql))
  303. (defun memq (elt list)
  304. (%member elt list #'eq))
  305. (defun assoc (key list)
  306. (funcall (@ (srfi srfi-1) assoc) key list #'equal))
  307. (defun assq (key list)
  308. (funcall (@ (srfi srfi-1) assoc) key list #'eq))
  309. (defun rplaca (cell newcar)
  310. (funcall (@ (guile) set-car!) cell newcar)
  311. newcar)
  312. (defun rplacd (cell newcdr)
  313. (funcall (@ (guile) set-cdr!) cell newcdr)
  314. newcdr)
  315. (defun caar (x)
  316. (car (car x)))
  317. (defun cadr (x)
  318. (car (cdr x)))
  319. (defun cdar (x)
  320. (cdr (car x)))
  321. (defun cddr (x)
  322. (cdr (cdr x)))
  323. (defmacro dolist (spec &rest body)
  324. (apply #'(lambda (var list &optional result)
  325. `(mapc #'(lambda (,var)
  326. ,@body
  327. ,result)
  328. ,list))
  329. spec))
  330. ;;; Strings
  331. (defun string (&rest characters)
  332. (funcall (@ (guile) list->string)
  333. (mapcar (@ (guile) integer->char) characters)))
  334. (defun stringp (object)
  335. (funcall (@ (guile) string?) object))
  336. (defun string-equal (s1 s2)
  337. (let ((s1 (if (symbolp s1) (symbol-name s1) s1))
  338. (s2 (if (symbolp s2) (symbol-name s2) s2)))
  339. (funcall (@ (guile) string=?) s1 s2)))
  340. (fset 'string= 'string-equal)
  341. (defun substring (string from &optional to)
  342. (apply (@ (guile) substring) string from (if to (list to) nil)))
  343. (defun upcase (obj)
  344. (funcall (@ (guile) string-upcase) obj))
  345. (defun downcase (obj)
  346. (funcall (@ (guile) string-downcase) obj))
  347. (defun string-match (regexp string &optional start)
  348. (let ((m (funcall (@ (ice-9 regex) string-match)
  349. regexp
  350. string
  351. (or start 0))))
  352. (if m
  353. (funcall (@ (ice-9 regex) match:start) m 0)
  354. nil)))
  355. ;; Vectors
  356. (defun make-vector (length init)
  357. (funcall (@ (guile) make-vector) length init))
  358. ;;; Sequences
  359. (defun length (sequence)
  360. (funcall (if (listp sequence)
  361. (@ (guile) length)
  362. (@ (guile) generalized-vector-length))
  363. sequence))
  364. (defun mapcar (function sequence)
  365. (funcall (@ (guile) map) function sequence))
  366. (defun mapc (function sequence)
  367. (funcall (@ (guile) for-each) function sequence)
  368. sequence)
  369. (defun aref (array idx)
  370. (funcall (@ (guile) generalized-vector-ref) array idx))
  371. (defun aset (array idx newelt)
  372. (funcall (@ (guile) generalized-vector-set!) array idx newelt)
  373. newelt)
  374. (defun concat (&rest sequences)
  375. (apply (@ (guile) string-append) sequences))
  376. ;;; Property lists
  377. (defun %plist-member (plist property test)
  378. (cond
  379. ((null plist) nil)
  380. ((consp plist)
  381. (if (funcall test (car plist) property)
  382. (cdr plist)
  383. (%plist-member (cdr (cdr plist)) property test)))
  384. (t (signal 'wrong-type-argument `(listp ,plist)))))
  385. (defun %plist-get (plist property test)
  386. (car (%plist-member plist property test)))
  387. (defun %plist-put (plist property value test)
  388. (let ((x (%plist-member plist property test)))
  389. (if x
  390. (progn (setcar x value) plist)
  391. (cons property (cons value plist)))))
  392. (defun plist-get (plist property)
  393. (%plist-get plist property #'eq))
  394. (defun plist-put (plist property value)
  395. (%plist-put plist property value #'eq))
  396. (defun plist-member (plist property)
  397. (%plist-member plist property #'eq))
  398. (defun lax-plist-get (plist property)
  399. (%plist-get plist property #'equal))
  400. (defun lax-plist-put (plist property value)
  401. (%plist-put plist property value #'equal))
  402. (defvar plist-function (funcall (@ (guile) make-object-property)))
  403. (defun symbol-plist (symbol)
  404. (funcall plist-function symbol))
  405. (defun setplist (symbol plist)
  406. (funcall (funcall (@ (guile) setter) plist-function) symbol plist))
  407. (defun get (symbol propname)
  408. (plist-get (symbol-plist symbol) propname))
  409. (defun put (symbol propname value)
  410. (setplist symbol (plist-put (symbol-plist symbol) propname value)))
  411. ;;; Nonlocal exits
  412. (defmacro condition-case (var bodyform &rest handlers)
  413. (let ((key (make-symbol "key"))
  414. (error-symbol (make-symbol "error-symbol"))
  415. (data (make-symbol "data"))
  416. (conditions (make-symbol "conditions")))
  417. (flet ((handler->cond-clause (handler)
  418. `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
  419. (if (consp (car handler))
  420. (car handler)
  421. (list (car handler)))))
  422. ,@(cdr handler))))
  423. `(funcall (@ (guile) catch)
  424. 'elisp-condition
  425. #'(lambda () ,bodyform)
  426. #'(lambda (,key ,error-symbol ,data)
  427. (declare (lexical ,key ,error-symbol ,data))
  428. (let ((,conditions
  429. (get ,error-symbol 'error-conditions))
  430. ,@(if var
  431. `((,var (cons ,error-symbol ,data)))
  432. '()))
  433. (declare (lexical ,conditions
  434. ,@(if var `(,var) '())))
  435. (cond ,@(mapcar #'handler->cond-clause handlers)
  436. (t (signal ,error-symbol ,data)))))))))
  437. (put 'error 'error-conditions '(error))
  438. (put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
  439. (put 'invalid-function 'error-conditions '(invalid-function error))
  440. (put 'no-catch 'error-conditions '(no-catch error))
  441. (put 'throw 'error-conditions '(throw))
  442. (defvar %catch nil)
  443. (defmacro catch (tag &rest body)
  444. (let ((tag-value (make-symbol "tag-value"))
  445. (c (make-symbol "c"))
  446. (data (make-symbol "data")))
  447. `(let ((,tag-value ,tag))
  448. (declare (lexical ,tag-value))
  449. (condition-case ,c
  450. (let ((%catch t))
  451. ,@body)
  452. (throw
  453. (let ((,data (cdr ,c)))
  454. (declare (lexical ,data))
  455. (if (eq (car ,data) ,tag-value)
  456. (car (cdr ,data))
  457. (apply #'throw ,data))))))))
  458. (defun throw (tag value)
  459. (signal (if %catch 'throw 'no-catch) (list tag value)))
  460. ;;; I/O
  461. (defun princ (object)
  462. (funcall (@ (guile) display) object))
  463. (defun print (object)
  464. (funcall (@ (guile) write) object))
  465. (defun terpri ()
  466. (funcall (@ (guile) newline)))
  467. (defun format* (stream string &rest args)
  468. (apply (@ (guile) format) stream string args))
  469. (defun send-string-to-terminal (string)
  470. (princ string))
  471. (defun read-from-minibuffer (prompt &rest ignore)
  472. (princ prompt)
  473. (let ((value (funcall (@ (ice-9 rdelim) read-line))))
  474. (if (funcall (@ (guile) eof-object?) value)
  475. ""
  476. value)))
  477. (defun prin1-to-string (object)
  478. (format* nil "~S" object))
  479. ;; Random number generation
  480. (defvar %random-state (funcall (@ (guile) copy-random-state)
  481. (@ (guile) *random-state*)))
  482. (defun random (&optional limit)
  483. (if (eq limit t)
  484. (setq %random-state
  485. (funcall (@ (guile) random-state-from-platform))))
  486. (funcall (@ (guile) random)
  487. (if (wholenump limit)
  488. limit
  489. (@ (guile) most-positive-fixnum))
  490. %random-state))