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