module/language/elisp/boot.el

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