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

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