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

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