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

;;; Guile Emacs Lisp

;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA

;;; Code:

(define-module (language elisp runtime function-slot)
  #:use-module (language elisp runtime)
  #:use-module (system base compile))

;;; This module contains the function-slots of elisp symbols. Elisp
;;; built-in functions are implemented as predefined function bindings
;;; here.

;;; Equivalence and equalness predicates.

(built-in-func eq (lambda (a b)
                    (elisp-bool (eq? a b))))

(built-in-func equal (lambda (a b)
                       (elisp-bool (equal? a b))))

;;; Number predicates.

(built-in-func floatp (lambda (num)
                        (elisp-bool (and (real? num)
                                         (or (inexact? num)
                                             (prim not (integer? num)))))))

(built-in-func integerp (lambda (num)
                          (elisp-bool (and (exact? num)
                                           (integer? num)))))

(built-in-func numberp (lambda (num)
                         (elisp-bool (real? num))))

(built-in-func wholenump (lambda (num)
                           (elisp-bool (and (exact? num)
                                            (integer? num)
                                            (prim >= num 0)))))

(built-in-func zerop (lambda (num)
                       (elisp-bool (prim = num 0))))

;;; Number comparisons.

(built-in-func = (lambda (num1 num2)
                   (elisp-bool (prim = num1 num2))))

(built-in-func /= (lambda (num1 num2)
                    (elisp-bool (prim not (prim = num1 num2)))))

(built-in-func < (lambda (num1 num2)
                   (elisp-bool (prim < num1 num2))))

(built-in-func <= (lambda (num1 num2)
                    (elisp-bool (prim <= num1 num2))))

(built-in-func > (lambda (num1 num2)
                   (elisp-bool (prim > num1 num2))))

(built-in-func >= (lambda (num1 num2)
                    (elisp-bool (prim >= num1 num2))))

(built-in-func max (lambda (. nums)
                     (prim apply (@ (guile) max) nums)))

(built-in-func min (lambda (. nums)
                     (prim apply (@ (guile) min) nums)))

(built-in-func abs (@ (guile) abs))

;;; Number conversion.

(built-in-func float (lambda (num)
                       (if (exact? num)
                         (exact->inexact num)
                         num)))

;;; TODO: truncate, floor, ceiling, round.

;;; Arithmetic functions.

(built-in-func 1+ (@ (guile) 1+))

(built-in-func 1- (@ (guile) 1-))

(built-in-func + (@ (guile) +))

(built-in-func - (@ (guile) -))

(built-in-func * (@ (guile) *))

(built-in-func % (@ (guile) modulo))

;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
;;; values).

;;; Floating-point rounding operations.

(built-in-func ffloor (@ (guile) floor))

(built-in-func fceiling (@ (guile) ceiling))

(built-in-func ftruncate (@ (guile) truncate))

(built-in-func fround (@ (guile) round))

;;; List predicates.

(built-in-func consp
  (lambda (el)
    (elisp-bool (pair? el))))

(built-in-func atomp
  (lambda (el)
    (elisp-bool (prim not (pair? el)))))

(built-in-func listp
  (lambda (el)
    (elisp-bool (or (pair? el) (null? el)))))

(built-in-func nlistp
  (lambda (el)
    (elisp-bool (and (prim not (pair? el))
                     (prim not (null? el))))))

(built-in-func null
  (lambda (el)
    (elisp-bool (null? el))))

;;; Accessing list elements.

(built-in-func car
  (lambda (el)
    (if (null? el)
      nil-value
      (prim car el))))

(built-in-func cdr
  (lambda (el)
    (if (null? el)
      nil-value
      (prim cdr el))))

(built-in-func car-safe
  (lambda (el)
    (if (pair? el)
      (prim car el)
      nil-value)))

(built-in-func cdr-safe
  (lambda (el)
    (if (pair? el)
      (prim cdr el)
      nil-value)))

(built-in-func nth
  (lambda (n lst)
    (if (negative? n)
      (prim car lst)
      (let iterate ((i n)
                    (tail lst))
        (cond
          ((null? tail) nil-value)
          ((zero? i) (prim car tail))
          (else (iterate (prim 1- i) (prim cdr tail))))))))

(built-in-func nthcdr
  (lambda (n lst)
    (if (negative? n)
      lst
      (let iterate ((i n)
                    (tail lst))
        (cond
          ((null? tail) nil-value)
          ((zero? i) tail)
          (else (iterate (prim 1- i) (prim cdr tail))))))))

(built-in-func length (@ (guile) length))

;;; Building lists.

(built-in-func cons (@ (guile) cons))

(built-in-func list (@ (guile) list))

(built-in-func make-list
  (lambda (len obj)
    (prim make-list len obj)))

(built-in-func append (@ (guile) append))

(built-in-func reverse (@ (guile) reverse))

(built-in-func copy-tree (@ (guile) copy-tree))

(built-in-func number-sequence
  (lambda (from . rest)
    (if (prim > (prim length rest) 2)
      (runtime-error "too many arguments for number-sequence"
                     (prim cdddr rest))
      (if (null? rest)
        `(,from)
        (let ((to (prim car rest))
              (sep (if (or (null? (prim cdr rest))
                           (eq? nil-value (prim cadr rest)))
                     1
                     (prim cadr rest))))
          (cond
            ((or (eq? nil-value to) (prim = to from)) `(,from))
            ((and (zero? sep) (prim not (prim = from to)))
             (runtime-error "infinite list in number-sequence"))
            ((prim < (prim * to sep) (prim * from sep)) '())
            (else
              (let iterate ((i (prim +
                                  from
                                  (prim * sep
                                          (prim quotient
                                            (prim abs (prim - to from))
                                            (prim abs sep)))))
                            (result '()))
                (if (prim = i from)
                  (prim cons i result)
                  (iterate (prim - i sep) (prim cons i result)))))))))))

;;; Changing lists.

(built-in-func setcar
  (lambda (cell val)
    (prim set-car! cell val)
    val))

(built-in-func setcdr
  (lambda (cell val)
    (prim set-cdr! cell val)
    val))

;;; Accessing symbol bindings for symbols known only at runtime.

(built-in-func symbol-value
  (lambda (sym)
    (reference-variable-with-check value-slot-module sym)))

(built-in-func symbol-function
  (lambda (sym)
    (reference-variable-with-check function-slot-module sym)))

(built-in-func set
  (lambda (sym value)
    (set-variable! value-slot-module sym value)))

(built-in-func fset
  (lambda (sym value)
    (set-variable! function-slot-module sym value)))

(built-in-func makunbound
  (lambda (sym)
    (set-variable! value-slot-module sym void)
    sym))

(built-in-func fmakunbound
  (lambda (sym)
    (set-variable! function-slot-module sym void)
    sym))

(built-in-func boundp
  (lambda (sym)
    (elisp-bool (prim not
                  (eq? void (reference-variable value-slot-module sym))))))

(built-in-func fboundp
  (lambda (sym)
    (elisp-bool (prim not
                  (eq? void (reference-variable function-slot-module sym))))))

;;; Function calls. These must take care of special cases, like using
;;; symbols or raw lambda-lists as functions!

(built-in-func apply
  (lambda (func . args)
    (let ((real-func (cond
                       ((symbol? func)
                        (reference-variable-with-check function-slot-module
                                                       func))
                       ((list? func)
                        (if (and (prim not (null? func))
                                 (eq? (prim car func) 'lambda))
                          (compile func #:from 'elisp #:to 'value)
                          (runtime-error "list is not a function" func)))
                       (else func))))
      (prim apply (@ (guile) apply) real-func args))))

(built-in-func funcall
  (let ((myapply (fluid-ref apply)))
    (lambda (func . args)
      (myapply func args))))

;;; Throw can be implemented as built-in function.

(built-in-func throw
  (lambda (tag value)
    (prim throw 'elisp-exception tag value)))

;;; Miscellaneous.

(built-in-func not
  (lambda (x)
    (if x nil-value t-value)))

(built-in-func eval
  (lambda (form)
    (compile form #:from 'elisp #:to 'value)))