module/language/elisp/runtime/function-slot.scm

   1 ;;; Guile Emacs Lisp
   2
   3 ;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but 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 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language elisp runtime function-slot)
  22   #:use-module (language elisp runtime)
  23   #:use-module (system base compile))
  24
  25 ;;; This module contains the function-slots of elisp symbols.  Elisp
  26 ;;; built-in functions are implemented as predefined function bindings
  27 ;;; here.
  28
  29 ;;; Equivalence and equalness predicates.
  30
  31 (built-in-func eq (lambda (a b)
  32                     (elisp-bool (eq? a b))))
  33
  34 (built-in-func equal (lambda (a b)
  35                        (elisp-bool (equal? a b))))
  36
  37 ;;; Number predicates.
  38
  39 (built-in-func floatp (lambda (num)
  40                         (elisp-bool (and (real? num)
  41                                          (or (inexact? num)
  42                                              (prim not (integer? num)))))))
  43
  44 (built-in-func integerp (lambda (num)
  45                           (elisp-bool (and (exact? num)
  46                                            (integer? num)))))
  47
  48 (built-in-func numberp (lambda (num)
  49                          (elisp-bool (real? num))))
  50
  51 (built-in-func wholenump (lambda (num)
  52                            (elisp-bool (and (exact? num)
  53                                             (integer? num)
  54                                             (prim >= num 0)))))
  55
  56 (built-in-func zerop (lambda (num)
  57                        (elisp-bool (prim = num 0))))
  58
  59 ;;; Number comparisons.
  60
  61 (built-in-func = (lambda (num1 num2)
  62                    (elisp-bool (prim = num1 num2))))
  63
  64 (built-in-func /= (lambda (num1 num2)
  65                     (elisp-bool (prim not (prim = num1 num2)))))
  66
  67 (built-in-func < (lambda (num1 num2)
  68                    (elisp-bool (prim < num1 num2))))
  69
  70 (built-in-func <= (lambda (num1 num2)
  71                     (elisp-bool (prim <= num1 num2))))
  72
  73 (built-in-func > (lambda (num1 num2)
  74                    (elisp-bool (prim > num1 num2))))
  75
  76 (built-in-func >= (lambda (num1 num2)
  77                     (elisp-bool (prim >= num1 num2))))
  78
  79 (built-in-func max (lambda (. nums)
  80                      (prim apply (@ (guile) max) nums)))
  81
  82 (built-in-func min (lambda (. nums)
  83                      (prim apply (@ (guile) min) nums)))
  84
  85 (built-in-func abs (@ (guile) abs))
  86
  87 ;;; Number conversion.
  88
  89 (built-in-func float (lambda (num)
  90                        (if (exact? num)
  91                          (exact->inexact num)
  92                          num)))
  93
  94 ;;; TODO: truncate, floor, ceiling, round.
  95
  96 ;;; Arithmetic functions.
  97
  98 (built-in-func 1+ (@ (guile) 1+))
  99
 100 (built-in-func 1- (@ (guile) 1-))
 101
 102 (built-in-func + (@ (guile) +))
 103
 104 (built-in-func - (@ (guile) -))
 105
 106 (built-in-func * (@ (guile) *))
 107
 108 (built-in-func % (@ (guile) modulo))
 109
 110 ;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
 111 ;;; values).
 112
 113 ;;; Floating-point rounding operations.
 114
 115 (built-in-func ffloor (@ (guile) floor))
 116
 117 (built-in-func fceiling (@ (guile) ceiling))
 118
 119 (built-in-func ftruncate (@ (guile) truncate))
 120
 121 (built-in-func fround (@ (guile) round))
 122
 123 ;;; List predicates.
 124
 125 (built-in-func consp
 126   (lambda (el)
 127     (elisp-bool (pair? el))))
 128
 129 (built-in-func atomp
 130   (lambda (el)
 131     (elisp-bool (prim not (pair? el)))))
 132
 133 (built-in-func listp
 134   (lambda (el)
 135     (elisp-bool (or (pair? el) (null? el)))))
 136
 137 (built-in-func nlistp
 138   (lambda (el)
 139     (elisp-bool (and (prim not (pair? el))
 140                      (prim not (null? el))))))
 141
 142 (built-in-func null
 143   (lambda (el)
 144     (elisp-bool (null? el))))
 145
 146 ;;; Accessing list elements.
 147
 148 (built-in-func car
 149   (lambda (el)
 150     (if (null? el)
 151       nil-value
 152       (prim car el))))
 153
 154 (built-in-func cdr
 155   (lambda (el)
 156     (if (null? el)
 157       nil-value
 158       (prim cdr el))))
 159
 160 (built-in-func car-safe
 161   (lambda (el)
 162     (if (pair? el)
 163       (prim car el)
 164       nil-value)))
 165
 166 (built-in-func cdr-safe
 167   (lambda (el)
 168     (if (pair? el)
 169       (prim cdr el)
 170       nil-value)))
 171
 172 (built-in-func nth
 173   (lambda (n lst)
 174     (if (negative? n)
 175       (prim car lst)
 176       (let iterate ((i n)
 177                     (tail lst))
 178         (cond
 179           ((null? tail) nil-value)
 180           ((zero? i) (prim car tail))
 181           (else (iterate (prim 1- i) (prim cdr tail))))))))
 182
 183 (built-in-func nthcdr
 184   (lambda (n lst)
 185     (if (negative? n)
 186       lst
 187       (let iterate ((i n)
 188                     (tail lst))
 189         (cond
 190           ((null? tail) nil-value)
 191           ((zero? i) tail)
 192           (else (iterate (prim 1- i) (prim cdr tail))))))))
 193
 194 (built-in-func length (@ (guile) length))
 195
 196 ;;; Building lists.
 197
 198 (built-in-func cons (@ (guile) cons))
 199
 200 (built-in-func list (@ (guile) list))
 201
 202 (built-in-func make-list
 203   (lambda (len obj)
 204     (prim make-list len obj)))
 205
 206 (built-in-func append (@ (guile) append))
 207
 208 (built-in-func reverse (@ (guile) reverse))
 209
 210 (built-in-func copy-tree (@ (guile) copy-tree))
 211
 212 (built-in-func number-sequence
 213   (lambda (from . rest)
 214     (if (prim > (prim length rest) 2)
 215       (runtime-error "too many arguments for number-sequence"
 216                      (prim cdddr rest))
 217       (if (null? rest)
 218         `(,from)
 219         (let ((to (prim car rest))
 220               (sep (if (or (null? (prim cdr rest))
 221                            (eq? nil-value (prim cadr rest)))
 222                      1
 223                      (prim cadr rest))))
 224           (cond
 225             ((or (eq? nil-value to) (prim = to from)) `(,from))
 226             ((and (zero? sep) (prim not (prim = from to)))
 227              (runtime-error "infinite list in number-sequence"))
 228             ((prim < (prim * to sep) (prim * from sep)) '())
 229             (else
 230               (let iterate ((i (prim +
 231                                   from
 232                                   (prim * sep
 233                                           (prim quotient
 234                                             (prim abs (prim - to from))
 235                                             (prim abs sep)))))
 236                             (result '()))
 237                 (if (prim = i from)
 238                   (prim cons i result)
 239                   (iterate (prim - i sep) (prim cons i result)))))))))))
 240
 241 ;;; Changing lists.
 242
 243 (built-in-func setcar
 244   (lambda (cell val)
 245     (prim set-car! cell val)
 246     val))
 247
 248 (built-in-func setcdr
 249   (lambda (cell val)
 250     (prim set-cdr! cell val)
 251     val))
 252
 253 ;;; Accessing symbol bindings for symbols known only at runtime.
 254
 255 (built-in-func symbol-value
 256   (lambda (sym)
 257     (reference-variable-with-check value-slot-module sym)))
 258
 259 (built-in-func symbol-function
 260   (lambda (sym)
 261     (reference-variable-with-check function-slot-module sym)))
 262
 263 (built-in-func set
 264   (lambda (sym value)
 265     (set-variable! value-slot-module sym value)))
 266
 267 (built-in-func fset
 268   (lambda (sym value)
 269     (set-variable! function-slot-module sym value)))
 270
 271 (built-in-func makunbound
 272   (lambda (sym)
 273     (set-variable! value-slot-module sym void)
 274     sym))
 275
 276 (built-in-func fmakunbound
 277   (lambda (sym)
 278     (set-variable! function-slot-module sym void)
 279     sym))
 280
 281 (built-in-func boundp
 282   (lambda (sym)
 283     (elisp-bool (prim not
 284                   (eq? void (reference-variable value-slot-module sym))))))
 285
 286 (built-in-func fboundp
 287   (lambda (sym)
 288     (elisp-bool (prim not
 289                   (eq? void (reference-variable function-slot-module sym))))))
 290
 291 ;;; Function calls. These must take care of special cases, like using
 292 ;;; symbols or raw lambda-lists as functions!
 293
 294 (built-in-func apply
 295   (lambda (func . args)
 296     (let ((real-func (cond
 297                        ((symbol? func)
 298                         (reference-variable-with-check function-slot-module
 299                                                        func))
 300                        ((list? func)
 301                         (if (and (prim not (null? func))
 302                                  (eq? (prim car func) 'lambda))
 303                           (compile func #:from 'elisp #:to 'value)
 304                           (runtime-error "list is not a function" func)))
 305                        (else func))))
 306       (prim apply (@ (guile) apply) real-func args))))
 307
 308 (built-in-func funcall
 309   (let ((myapply (fluid-ref apply)))
 310     (lambda (func . args)
 311       (myapply func args))))
 312
 313 ;;; Throw can be implemented as built-in function.
 314
 315 (built-in-func throw
 316   (lambda (tag value)
 317     (prim throw 'elisp-exception tag value)))
 318
 319 ;;; Miscellaneous.
 320
 321 (built-in-func not
 322   (lambda (x)
 323     (if x nil-value t-value)))
 324
 325 (built-in-func eval
 326   (lambda (form)
 327     (compile form #:from 'elisp #:to 'value)))