| 1 | ;;; Guile Emacs Lisp -*- lexical-binding: t -*- |
| 2 | |
| 3 | ;;; Copyright (C) 2011 Free Software Foundation, Inc. |
| 4 | |
| 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. |
| 9 | ;;; |
| 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. |
| 14 | ;;; |
| 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 |
| 18 | ;;; 02110-1301 USA |
| 19 | |
| 20 | ;;; Code: |
| 21 | |
| 22 | (defmacro @ (module symbol) |
| 23 | `(guile-ref ,module ,symbol)) |
| 24 | |
| 25 | (defmacro @@ (module symbol) |
| 26 | `(guile-private-ref ,module ,symbol)) |
| 27 | |
| 28 | (defmacro defun (name args &rest body) |
| 29 | `(let ((proc (function (lambda ,args ,@body)))) |
| 30 | (%funcall (@ (language elisp runtime) set-symbol-function!) |
| 31 | ',name |
| 32 | proc) |
| 33 | (%funcall (@ (guile) set-procedure-property!) |
| 34 | proc 'name ',name) |
| 35 | ',name)) |
| 36 | |
| 37 | (defun omega () (omega)) |
| 38 | |
| 39 | (defmacro eval-and-compile (&rest body) |
| 40 | `(progn |
| 41 | (eval-when-compile ,@body) |
| 42 | (progn ,@body))) |
| 43 | |
| 44 | (eval-and-compile |
| 45 | (defun eval (form) |
| 46 | (%funcall (@ (language elisp runtime) eval-elisp) form))) |
| 47 | |
| 48 | (eval-and-compile |
| 49 | (defun null (object) |
| 50 | (if object nil t)) |
| 51 | (defun consp (object) |
| 52 | (%funcall (@ (guile) pair?) object)) |
| 53 | (defun listp (object) |
| 54 | (if object (consp object) t)) |
| 55 | (defun car (list) |
| 56 | (if list (%funcall (@ (guile) car) list) nil)) |
| 57 | (defun cdr (list) |
| 58 | (if list (%funcall (@ (guile) cdr) list) nil)) |
| 59 | (defun make-symbol (name) |
| 60 | (%funcall (@ (guile) make-symbol) name)) |
| 61 | (defun gensym () |
| 62 | (%funcall (@ (guile) gensym))) |
| 63 | (defun signal (error-symbol data) |
| 64 | (%funcall (@ (guile) throw) 'elisp-condition error-symbol data))) |
| 65 | |
| 66 | (defmacro lambda (&rest cdr) |
| 67 | `#'(lambda ,@cdr)) |
| 68 | |
| 69 | (defmacro prog1 (first &rest body) |
| 70 | (let ((temp (gensym))) |
| 71 | `(let ((,temp ,first)) |
| 72 | (declare (lexical ,temp)) |
| 73 | ,@body |
| 74 | ,temp))) |
| 75 | |
| 76 | (defun interactive (&optional arg) |
| 77 | nil) |
| 78 | |
| 79 | (defmacro prog2 (form1 form2 &rest body) |
| 80 | `(progn ,form1 (prog1 ,form2 ,@body))) |
| 81 | |
| 82 | (defmacro cond (&rest clauses) |
| 83 | (if (null clauses) |
| 84 | nil |
| 85 | (let ((first (car clauses)) |
| 86 | (rest (cdr clauses))) |
| 87 | (if (listp first) |
| 88 | (let ((condition (car first)) |
| 89 | (body (cdr first))) |
| 90 | (if (null body) |
| 91 | (let ((temp (gensym))) |
| 92 | `(let ((,temp ,condition)) |
| 93 | (declare (lexical ,temp)) |
| 94 | (if ,temp |
| 95 | ,temp |
| 96 | (cond ,@rest)))) |
| 97 | `(if ,condition |
| 98 | (progn ,@body) |
| 99 | (cond ,@rest)))) |
| 100 | (signal 'wrong-type-argument `(listp ,first)))))) |
| 101 | |
| 102 | (defmacro and (&rest conditions) |
| 103 | (cond ((null conditions) t) |
| 104 | ((null (cdr conditions)) (car conditions)) |
| 105 | (t `(if ,(car conditions) |
| 106 | (and ,@(cdr conditions)) |
| 107 | nil)))) |
| 108 | |
| 109 | (defmacro or (&rest conditions) |
| 110 | (cond ((null conditions) nil) |
| 111 | ((null (cdr conditions)) (car conditions)) |
| 112 | (t (let ((temp (gensym))) |
| 113 | `(let ((,temp ,(car conditions))) |
| 114 | (declare (lexical ,temp)) |
| 115 | (if ,temp |
| 116 | ,temp |
| 117 | (or ,@(cdr conditions)))))))) |
| 118 | |
| 119 | (defmacro lexical-let (bindings &rest body) |
| 120 | (labels ((loop (list vars) |
| 121 | (if (null list) |
| 122 | `(let ,bindings |
| 123 | (declare (lexical ,@vars)) |
| 124 | ,@body) |
| 125 | (loop (cdr list) |
| 126 | (if (consp (car list)) |
| 127 | `(,(car (car list)) ,@vars) |
| 128 | `(,(car list) ,@vars)))))) |
| 129 | (loop bindings '()))) |
| 130 | |
| 131 | (defmacro lexical-let* (bindings &rest body) |
| 132 | (labels ((loop (list vars) |
| 133 | (if (null list) |
| 134 | `(let* ,bindings |
| 135 | (declare (lexical ,@vars)) |
| 136 | ,@body) |
| 137 | (loop (cdr list) |
| 138 | (if (consp (car list)) |
| 139 | (cons (car (car list)) vars) |
| 140 | (cons (car list) vars)))))) |
| 141 | (loop bindings '()))) |
| 142 | |
| 143 | (defmacro while (test &rest body) |
| 144 | (let ((loop (gensym))) |
| 145 | `(labels ((,loop () |
| 146 | (if ,test |
| 147 | (progn ,@body (,loop)) |
| 148 | nil))) |
| 149 | (,loop)))) |
| 150 | |
| 151 | (defmacro unwind-protect (bodyform &rest unwindforms) |
| 152 | `(%funcall (@ (guile) dynamic-wind) |
| 153 | #'(lambda () nil) |
| 154 | #'(lambda () ,bodyform) |
| 155 | #'(lambda () ,@unwindforms))) |
| 156 | |
| 157 | (defmacro when (cond &rest body) |
| 158 | `(if ,cond |
| 159 | (progn ,@body))) |
| 160 | |
| 161 | (defmacro unless (cond &rest body) |
| 162 | `(when (not ,cond) |
| 163 | ,@body)) |
| 164 | |
| 165 | (defun symbolp (object) |
| 166 | (%funcall (@ (guile) symbol?) object)) |
| 167 | |
| 168 | (defun %functionp (object) |
| 169 | (%funcall (@ (guile) procedure?) object)) |
| 170 | |
| 171 | (defun symbol-function (symbol) |
| 172 | (let ((f (%funcall (@ (language elisp runtime) symbol-function) |
| 173 | symbol))) |
| 174 | (if (%funcall (@ (language elisp falias) falias?) f) |
| 175 | (%funcall (@ (language elisp falias) falias-object) f) |
| 176 | f))) |
| 177 | |
| 178 | (defun eval (form) |
| 179 | (%funcall (@ (system base compile) compile) |
| 180 | form |
| 181 | (%funcall (@ (guile) symbol->keyword) 'from) |
| 182 | 'elisp |
| 183 | (%funcall (@ (guile) symbol->keyword) 'to) |
| 184 | 'value)) |
| 185 | |
| 186 | (defun %indirect-function (object) |
| 187 | (cond |
| 188 | ((%functionp object) |
| 189 | object) |
| 190 | ((null object) |
| 191 | (signal 'void-function nil)) |
| 192 | ((symbolp object) ;++ cycle detection |
| 193 | (%indirect-function |
| 194 | (%funcall (@ (language elisp runtime) symbol-function) object))) |
| 195 | ((listp object) |
| 196 | (eval `(function ,object))) |
| 197 | (t |
| 198 | (signal 'invalid-function `(,object))))) |
| 199 | |
| 200 | (defun apply (function &rest arguments) |
| 201 | (%funcall (@ (guile) apply) |
| 202 | (@ (guile) apply) |
| 203 | (%indirect-function function) |
| 204 | arguments)) |
| 205 | |
| 206 | (defun funcall (function &rest arguments) |
| 207 | (%funcall (@ (guile) apply) |
| 208 | (%indirect-function function) |
| 209 | arguments)) |
| 210 | |
| 211 | (defun autoload-do-load (fundef &optional funname macro-only) |
| 212 | (and (load (cadr fundef)) |
| 213 | (%indirect-function funname))) |
| 214 | |
| 215 | (defun fset (symbol definition) |
| 216 | (funcall (@ (language elisp runtime) set-symbol-function!) |
| 217 | symbol |
| 218 | definition)) |
| 219 | |
| 220 | (defun eq (obj1 obj2) |
| 221 | (if obj1 |
| 222 | (%funcall (@ (guile) eq?) obj1 obj2) |
| 223 | (if obj2 nil t))) |
| 224 | |
| 225 | (defun nthcdr (n list) |
| 226 | (let ((i 0)) |
| 227 | (while (< i n) |
| 228 | (setq list (cdr list) |
| 229 | i (+ i 1))) |
| 230 | list)) |
| 231 | |
| 232 | (defun nth (n list) |
| 233 | (car (nthcdr n list))) |
| 234 | |
| 235 | (defun fset (symbol definition) |
| 236 | (funcall (@ (language elisp runtime) set-symbol-function!) |
| 237 | symbol |
| 238 | (cond |
| 239 | ((%funcall (@ (guile) procedure?) definition) |
| 240 | definition) |
| 241 | ((and (consp definition) |
| 242 | (eq (car definition) 'macro)) |
| 243 | (if (%funcall (@ (guile) procedure?) (cdr definition)) |
| 244 | definition |
| 245 | (cons 'macro |
| 246 | (funcall (@ (language elisp falias) make-falias) |
| 247 | (function |
| 248 | (lambda (&rest args) (apply (cdr definition) args))) |
| 249 | (cdr definition))))) |
| 250 | ((and (consp definition) |
| 251 | (eq (car definition) 'autoload)) |
| 252 | (if (or (eq (nth 4 definition) 'macro) |
| 253 | (eq (nth 4 definition) t)) |
| 254 | (cons 'macro |
| 255 | (funcall |
| 256 | (@ (language elisp falias) make-falias) |
| 257 | (function (lambda (&rest args) |
| 258 | (apply (cdr (autoload-do-load definition symbol nil)) args))) |
| 259 | definition)) |
| 260 | (funcall |
| 261 | (@ (language elisp falias) make-falias) |
| 262 | (function (lambda (&rest args) |
| 263 | (apply (autoload-do-load definition symbol nil) args))) |
| 264 | definition))) |
| 265 | (t |
| 266 | (funcall (@ (language elisp falias) make-falias) |
| 267 | (function (lambda (&rest args) (apply definition args))) |
| 268 | definition)))) |
| 269 | definition) |
| 270 | |
| 271 | (defun gload (file) |
| 272 | (funcall (@ (system base compile) compile-file) |
| 273 | file |
| 274 | (funcall (@ (guile) symbol->keyword) 'from) |
| 275 | 'elisp |
| 276 | (funcall (@ (guile) symbol->keyword) 'to) |
| 277 | 'value) |
| 278 | t) |
| 279 | |
| 280 | ;;; Equality predicates |
| 281 | |
| 282 | (defun eql (obj1 obj2) |
| 283 | (if obj1 |
| 284 | (funcall (@ (guile) eqv?) obj1 obj2) |
| 285 | (null obj2))) |
| 286 | |
| 287 | (defun equal (obj1 obj2) |
| 288 | (if obj1 |
| 289 | (funcall (@ (guile) equal?) obj1 obj2) |
| 290 | (null obj2))) |
| 291 | |
| 292 | ;;; Symbols |
| 293 | |
| 294 | ;;; `symbolp' and `symbol-function' are defined above. |
| 295 | |
| 296 | (fset 'symbol-name (@ (guile) symbol->string)) |
| 297 | (fset 'symbol-value (@ (language elisp runtime) symbol-value)) |
| 298 | (fset 'set (@ (language elisp runtime) set-symbol-value!)) |
| 299 | (fset 'makunbound (@ (language elisp runtime) makunbound!)) |
| 300 | (fset 'fmakunbound (@ (language elisp runtime) fmakunbound!)) |
| 301 | (fset 'boundp (@ (language elisp runtime) symbol-bound?)) |
| 302 | (fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) |
| 303 | (fset 'intern (@ (guile) string->symbol)) |
| 304 | |
| 305 | ;(defun defvaralias (new-alias base-variable &optional docstring) |
| 306 | ; (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) |
| 307 | ; base-variable))) |
| 308 | ; (funcall (@ (language elisp runtime) set-symbol-fluid!) |
| 309 | ; new-alias |
| 310 | ; fluid) |
| 311 | ; base-variable)) |
| 312 | |
| 313 | ;;; Numerical type predicates |
| 314 | |
| 315 | (defun floatp (object) |
| 316 | (and (funcall (@ (guile) real?) object) |
| 317 | (or (funcall (@ (guile) inexact?) object) |
| 318 | (null (funcall (@ (guile) integer?) object))))) |
| 319 | |
| 320 | (defun integerp (object) |
| 321 | (and (funcall (@ (guile) integer?) object) |
| 322 | (funcall (@ (guile) exact?) object))) |
| 323 | |
| 324 | (defun numberp (object) |
| 325 | (funcall (@ (guile) real?) object)) |
| 326 | |
| 327 | (defun wholenump (object) |
| 328 | (and (integerp object) (>= object 0))) |
| 329 | |
| 330 | (defun zerop (object) |
| 331 | (= object 0)) |
| 332 | |
| 333 | ;;; Numerical comparisons |
| 334 | |
| 335 | (fset '= (@ (guile) =)) |
| 336 | |
| 337 | (defun /= (num1 num2) |
| 338 | (null (= num1 num2))) |
| 339 | |
| 340 | (fset '< (@ (guile) <)) |
| 341 | (fset '<= (@ (guile) <=)) |
| 342 | (fset '> (@ (guile) >)) |
| 343 | (fset '>= (@ (guile) >=)) |
| 344 | |
| 345 | (defun max (&rest numbers) |
| 346 | (apply (@ (guile) max) numbers)) |
| 347 | |
| 348 | (defun min (&rest numbers) |
| 349 | (apply (@ (guile) min) numbers)) |
| 350 | |
| 351 | ;;; Arithmetic functions |
| 352 | |
| 353 | (fset '1+ (@ (guile) 1+)) |
| 354 | (fset '1- (@ (guile) 1-)) |
| 355 | (fset '+ (@ (guile) +)) |
| 356 | (fset '- (@ (guile) -)) |
| 357 | (fset '* (@ (guile) *)) |
| 358 | (fset '% (@ (guile) modulo)) |
| 359 | (fset 'abs (@ (guile) abs)) |
| 360 | |
| 361 | ;;; Floating-point rounding |
| 362 | |
| 363 | (fset 'ffloor (@ (guile) floor)) |
| 364 | (fset 'fceiling (@ (guile) ceiling)) |
| 365 | (fset 'ftruncate (@ (guile) truncate)) |
| 366 | (fset 'fround (@ (guile) round)) |
| 367 | |
| 368 | ;;; Numeric conversion |
| 369 | |
| 370 | (defun float (arg) |
| 371 | (if (numberp arg) |
| 372 | (funcall (@ (guile) exact->inexact) arg) |
| 373 | (signal 'wrong-type-argument `(numberp ,arg)))) |
| 374 | |
| 375 | ;;; List predicates |
| 376 | |
| 377 | (fset 'not #'null) |
| 378 | |
| 379 | (defun atom (object) |
| 380 | (null (consp object))) |
| 381 | |
| 382 | (defun nlistp (object) |
| 383 | (null (listp object))) |
| 384 | |
| 385 | ;;; Lists |
| 386 | |
| 387 | (fset 'cons (@ (guile) cons)) |
| 388 | (fset 'list (@ (guile) list)) |
| 389 | (fset 'make-list (@ (guile) make-list)) |
| 390 | (fset 'append (@ (guile) append)) |
| 391 | (fset 'reverse (@ (guile) reverse)) |
| 392 | (fset 'nreverse (@ (guile) reverse!)) |
| 393 | |
| 394 | (defun car-safe (object) |
| 395 | (if (consp object) |
| 396 | (car object) |
| 397 | nil)) |
| 398 | |
| 399 | (defun cdr-safe (object) |
| 400 | (if (consp object) |
| 401 | (cdr object) |
| 402 | nil)) |
| 403 | |
| 404 | (defun setcar (cell newcar) |
| 405 | (if (consp cell) |
| 406 | (progn |
| 407 | (funcall (@ (guile) set-car!) cell newcar) |
| 408 | newcar) |
| 409 | (signal 'wrong-type-argument `(consp ,cell)))) |
| 410 | |
| 411 | (defun setcdr (cell newcdr) |
| 412 | (if (consp cell) |
| 413 | (progn |
| 414 | (funcall (@ (guile) set-cdr!) cell newcdr) |
| 415 | newcdr) |
| 416 | (signal 'wrong-type-argument `(consp ,cell)))) |
| 417 | |
| 418 | (defun %member (elt list test) |
| 419 | (cond |
| 420 | ((null list) nil) |
| 421 | ((consp list) |
| 422 | (if (funcall test elt (car list)) |
| 423 | list |
| 424 | (%member elt (cdr list) test))) |
| 425 | (t (signal 'wrong-type-argument `(listp ,list))))) |
| 426 | |
| 427 | (defun member (elt list) |
| 428 | (%member elt list #'equal)) |
| 429 | |
| 430 | (defun memql (elt list) |
| 431 | (%member elt list #'eql)) |
| 432 | |
| 433 | (defun memq (elt list) |
| 434 | (%member elt list #'eq)) |
| 435 | |
| 436 | (defun assoc (key list) |
| 437 | (funcall (@ (srfi srfi-1) assoc) key list #'equal)) |
| 438 | |
| 439 | (defun assq (key list) |
| 440 | (funcall (@ (srfi srfi-1) assoc) key list #'eq)) |
| 441 | |
| 442 | (defun rplaca (cell newcar) |
| 443 | (funcall (@ (guile) set-car!) cell newcar) |
| 444 | newcar) |
| 445 | |
| 446 | (defun rplacd (cell newcdr) |
| 447 | (funcall (@ (guile) set-cdr!) cell newcdr) |
| 448 | newcdr) |
| 449 | |
| 450 | (defun caar (x) |
| 451 | (car (car x))) |
| 452 | |
| 453 | (defun cadr (x) |
| 454 | (car (cdr x))) |
| 455 | |
| 456 | (defun cdar (x) |
| 457 | (cdr (car x))) |
| 458 | |
| 459 | (defun cddr (x) |
| 460 | (cdr (cdr x))) |
| 461 | |
| 462 | (defmacro dolist (spec &rest body) |
| 463 | (apply #'(lambda (var list &optional result) |
| 464 | (list 'progn |
| 465 | (list 'mapc |
| 466 | (cons 'lambda (cons (list var) body)) |
| 467 | list) |
| 468 | result)) |
| 469 | spec)) |
| 470 | |
| 471 | ;;; Strings |
| 472 | |
| 473 | (defun string (&rest characters) |
| 474 | (funcall (@ (guile) list->string) |
| 475 | (mapcar (@ (guile) integer->char) characters))) |
| 476 | |
| 477 | (defun stringp (object) |
| 478 | (funcall (@ (guile) string?) object)) |
| 479 | |
| 480 | (defun string-equal (s1 s2) |
| 481 | (let ((s1 (if (symbolp s1) (symbol-name s1) s1)) |
| 482 | (s2 (if (symbolp s2) (symbol-name s2) s2))) |
| 483 | (funcall (@ (guile) string=?) s1 s2))) |
| 484 | |
| 485 | (fset 'string= 'string-equal) |
| 486 | |
| 487 | (defun substring (string from &optional to) |
| 488 | (apply (@ (guile) substring) string from (if to (list to) nil))) |
| 489 | |
| 490 | (defun upcase (obj) |
| 491 | (funcall (@ (guile) string-upcase) obj)) |
| 492 | |
| 493 | (defun downcase (obj) |
| 494 | (funcall (@ (guile) string-downcase) obj)) |
| 495 | |
| 496 | (defun string-match (regexp string &optional start) |
| 497 | (let ((m (funcall (@ (ice-9 regex) string-match) |
| 498 | regexp |
| 499 | string |
| 500 | (or start 0)))) |
| 501 | (if m |
| 502 | (funcall (@ (ice-9 regex) match:start) m 0) |
| 503 | nil))) |
| 504 | |
| 505 | ;; Vectors |
| 506 | |
| 507 | (defun make-vector (length init) |
| 508 | (funcall (@ (guile) make-vector) length init)) |
| 509 | |
| 510 | ;;; Sequences |
| 511 | |
| 512 | (defun length (sequence) |
| 513 | (funcall (if (listp sequence) |
| 514 | (@ (guile) length) |
| 515 | (@ (guile) generalized-vector-length)) |
| 516 | sequence)) |
| 517 | |
| 518 | (defun mapcar (function sequence) |
| 519 | (funcall (@ (guile) map) function sequence)) |
| 520 | |
| 521 | (defun mapc (function sequence) |
| 522 | (funcall (@ (guile) for-each) function sequence) |
| 523 | sequence) |
| 524 | |
| 525 | (defun aref (array idx) |
| 526 | (funcall (@ (guile) generalized-vector-ref) array idx)) |
| 527 | |
| 528 | (defun aset (array idx newelt) |
| 529 | (funcall (@ (guile) generalized-vector-set!) array idx newelt) |
| 530 | newelt) |
| 531 | |
| 532 | (defun concat (&rest sequences) |
| 533 | (apply (@ (guile) string-append) sequences)) |
| 534 | |
| 535 | ;;; Property lists |
| 536 | |
| 537 | (defun %plist-member (plist property test) |
| 538 | (cond |
| 539 | ((null plist) nil) |
| 540 | ((consp plist) |
| 541 | (if (funcall test (car plist) property) |
| 542 | (cdr plist) |
| 543 | (%plist-member (cdr (cdr plist)) property test))) |
| 544 | (t (signal 'wrong-type-argument `(listp ,plist))))) |
| 545 | |
| 546 | (defun %plist-get (plist property test) |
| 547 | (car (%plist-member plist property test))) |
| 548 | |
| 549 | (defun %plist-put (plist property value test) |
| 550 | (let ((x (%plist-member plist property test))) |
| 551 | (if x |
| 552 | (progn (setcar x value) plist) |
| 553 | (cons property (cons value plist))))) |
| 554 | |
| 555 | (defun plist-get (plist property) |
| 556 | (%plist-get plist property #'eq)) |
| 557 | |
| 558 | (defun plist-put (plist property value) |
| 559 | (%plist-put plist property value #'eq)) |
| 560 | |
| 561 | (defun plist-member (plist property) |
| 562 | (%plist-member plist property #'eq)) |
| 563 | |
| 564 | (defun lax-plist-get (plist property) |
| 565 | (%plist-get plist property #'equal)) |
| 566 | |
| 567 | (defun lax-plist-put (plist property value) |
| 568 | (%plist-put plist property value #'equal)) |
| 569 | |
| 570 | (defvar plist-function (funcall (@ (guile) make-object-property))) |
| 571 | |
| 572 | (defun symbol-plist (symbol) |
| 573 | (funcall plist-function symbol)) |
| 574 | |
| 575 | (defun setplist (symbol plist) |
| 576 | (funcall (funcall (@ (guile) setter) plist-function) symbol plist)) |
| 577 | |
| 578 | (defun get (symbol propname) |
| 579 | (plist-get (symbol-plist symbol) propname)) |
| 580 | |
| 581 | (defun put (symbol propname value) |
| 582 | (setplist symbol (plist-put (symbol-plist symbol) propname value))) |
| 583 | |
| 584 | ;;; Nonlocal exits |
| 585 | |
| 586 | (defmacro condition-case (var bodyform &rest handlers) |
| 587 | (let ((key (make-symbol "key")) |
| 588 | (error-symbol (make-symbol "error-symbol")) |
| 589 | (data (make-symbol "data")) |
| 590 | (conditions (make-symbol "conditions"))) |
| 591 | (flet ((handler->cond-clause (handler) |
| 592 | `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions)) |
| 593 | (if (consp (car handler)) |
| 594 | (car handler) |
| 595 | (list (car handler))))) |
| 596 | ,@(cdr handler)))) |
| 597 | `(funcall (@ (guile) catch) |
| 598 | 'elisp-condition |
| 599 | #'(lambda () ,bodyform) |
| 600 | #'(lambda (,key ,error-symbol ,data) |
| 601 | (declare (lexical ,key ,error-symbol ,data)) |
| 602 | (let ((,conditions |
| 603 | (get ,error-symbol 'error-conditions)) |
| 604 | ,@(if var |
| 605 | `((,var (cons ,error-symbol ,data))) |
| 606 | '())) |
| 607 | (declare (lexical ,conditions |
| 608 | ,@(if var `(,var) '()))) |
| 609 | (cond ,@(mapcar #'handler->cond-clause handlers) |
| 610 | (t (signal ,error-symbol ,data))))))))) |
| 611 | |
| 612 | (put 'error 'error-conditions '(error)) |
| 613 | (put 'wrong-type-argument 'error-conditions '(wrong-type-argument error)) |
| 614 | (put 'invalid-function 'error-conditions '(invalid-function error)) |
| 615 | (put 'no-catch 'error-conditions '(no-catch error)) |
| 616 | (put 'throw 'error-conditions '(throw)) |
| 617 | |
| 618 | (defvar %catch nil) |
| 619 | |
| 620 | (defmacro catch (tag &rest body) |
| 621 | (let ((tag-value (make-symbol "tag-value")) |
| 622 | (c (make-symbol "c")) |
| 623 | (data (make-symbol "data"))) |
| 624 | `(let ((,tag-value ,tag)) |
| 625 | (declare (lexical ,tag-value)) |
| 626 | (condition-case ,c |
| 627 | (let ((%catch t)) |
| 628 | ,@body) |
| 629 | (throw |
| 630 | (let ((,data (cdr ,c))) |
| 631 | (declare (lexical ,data)) |
| 632 | (if (eq (car ,data) ,tag-value) |
| 633 | (car (cdr ,data)) |
| 634 | (apply #'throw ,data)))))))) |
| 635 | |
| 636 | (defun throw (tag value) |
| 637 | (signal (if %catch 'throw 'no-catch) (list tag value))) |
| 638 | |
| 639 | ;;; I/O |
| 640 | |
| 641 | (defun princ (object) |
| 642 | (funcall (@ (guile) display) object)) |
| 643 | |
| 644 | (defun print (object) |
| 645 | (funcall (@ (guile) write) object)) |
| 646 | |
| 647 | (defun prin1 (object) |
| 648 | (funcall (@ (guile) write) object)) |
| 649 | |
| 650 | (defun terpri () |
| 651 | (funcall (@ (guile) newline))) |
| 652 | |
| 653 | (defun format* (stream string &rest args) |
| 654 | (apply (@ (guile) format) stream string args)) |
| 655 | |
| 656 | (defun send-string-to-terminal (string) |
| 657 | (princ string)) |
| 658 | |
| 659 | (defun read-from-minibuffer (prompt &rest ignore) |
| 660 | (princ prompt) |
| 661 | (let ((value (funcall (@ (ice-9 rdelim) read-line)))) |
| 662 | (if (funcall (@ (guile) eof-object?) value) |
| 663 | "" |
| 664 | value))) |
| 665 | |
| 666 | (defun prin1-to-string (object) |
| 667 | (format* nil "~S" object)) |
| 668 | |
| 669 | ;; Random number generation |
| 670 | |
| 671 | (defvar %random-state (funcall (@ (guile) copy-random-state) |
| 672 | (@ (guile) *random-state*))) |
| 673 | |
| 674 | (defun random (&optional limit) |
| 675 | (if (eq limit t) |
| 676 | (setq %random-state |
| 677 | (funcall (@ (guile) random-state-from-platform)))) |
| 678 | (funcall (@ (guile) random) |
| 679 | (if (wholenump limit) |
| 680 | limit |
| 681 | (@ (guile) most-positive-fixnum)) |
| 682 | %random-state)) |
| 683 | |
| 684 | (defmacro save-excursion (&rest body) |
| 685 | `(call-with-save-excursion #'(lambda () ,@body))) |
| 686 | |
| 687 | (defmacro save-current-buffer (&rest body) |
| 688 | `(call-with-save-current-buffer #'(lambda () ,@body))) |
| 689 | |
| 690 | (defmacro save-restriction (&rest body) |
| 691 | `(call-with-save-restriction #'(lambda () ,@body))) |
| 692 | |
| 693 | (defmacro track-mouse (&rest body) |
| 694 | `(call-with-track-mouse #'(lambda () ,@body))) |
| 695 | |
| 696 | (defmacro setq-default (var value &rest args) |
| 697 | `(progn (set-default ',var ,value) |
| 698 | ,(if (null args) |
| 699 | var |
| 700 | `(setq-default ,@args)))) |
| 701 | |
| 702 | (defmacro catch (tag &rest body) |
| 703 | `(call-with-catch ,tag #'(lambda () ,@body))) |
| 704 | |
| 705 | (defmacro condition-case (var bodyform &rest args) |
| 706 | (if (consp args) |
| 707 | (let* ((handler (car args)) |
| 708 | (handlers (cdr args)) |
| 709 | (handler-conditions (car handler)) |
| 710 | (handler-body (cdr handler))) |
| 711 | `(call-with-handler ',var |
| 712 | ',handler-conditions |
| 713 | #'(lambda () ,@handler-body) |
| 714 | #'(lambda () |
| 715 | (condition-case ,var |
| 716 | ,bodyform |
| 717 | ,@handlers)))) |
| 718 | bodyform)) |
| 719 | |
| 720 | (defun backtrace-frame (nframes) |
| 721 | (let* ((stack (funcall (@ (guile) make-stack) t)) |
| 722 | (frame (stack-ref stack nframes)) |
| 723 | (proc (funcall (@ (guile) frame-procedure) frame)) |
| 724 | (pname (or (and (%functionp proc) |
| 725 | (funcall (@ (guile) procedure-name) proc)) |
| 726 | proc)) |
| 727 | (args (funcall (@ (guile) frame-arguments) frame))) |
| 728 | (cons t (cons pname args)))) |
| 729 | |
| 730 | (defun backtrace () |
| 731 | (interactive) |
| 732 | (let* ((stack (funcall (@ (guile) make-stack) t)) |
| 733 | (frame (funcall (@ (guile) stack-ref) stack 1)) |
| 734 | (space (funcall (@ (guile) integer->char) 32))) |
| 735 | (while frame |
| 736 | (princ (string 32 32)) |
| 737 | (let ((proc (funcall (@ (guile) frame-procedure) frame))) |
| 738 | (prin1 (or (and (%functionp proc) |
| 739 | (funcall (@ (guile) procedure-name) proc)) |
| 740 | proc))) |
| 741 | (prin1 (funcall (@ (guile) frame-arguments) frame)) |
| 742 | (terpri) |
| 743 | (setq frame (funcall (@ (guile) frame-previous) frame))) |
| 744 | nil)) |
| 745 | |
| 746 | (defun %set-eager-macroexpansion-mode (ignore) |
| 747 | nil) |