[bpt/guile.git] / module / language / elisp / boot.el

;;; Guile Emacs Lisp -*- lexical-binding: t -*-

;;; Copyright (C) 2011 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:

(defmacro @ (module symbol)
  `(guile-ref ,module ,symbol))

(defmacro eval-and-compile (&rest body)
  `(progn
     (eval-when-compile ,@body)
     (progn ,@body)))

(eval-and-compile
  (defun null (object)
    (if object nil t))
  (defun consp (object)
    (%funcall (@ (guile) pair?) object))
  (defun listp (object)
    (if object (consp object) t))
  (defun car (list)
    (if list (%funcall (@ (guile) car) list) nil))
  (defun cdr (list)
    (if list (%funcall (@ (guile) cdr) list) nil))
  (defun make-symbol (name)
    (%funcall (@ (guile) make-symbol) name))
  (defun signal (&rest args)
    (%funcall (@ (guile) throw) 'elisp-error args)))

(defmacro lambda (&rest cdr)
  `#'(lambda ,@cdr))

(defmacro prog1 (first &rest body)
  (let ((temp (make-symbol "prog1-temp")))
    `(let ((,temp ,first))
       (declare (lexical ,temp))
       ,@body
       ,temp)))

(defmacro prog2 (form1 form2 &rest body)
  `(progn ,form1 (prog1 ,form2 ,@body)))

(defmacro cond (&rest clauses)
  (if (null clauses)
      nil
    (let ((first (car clauses))
          (rest (cdr clauses)))
     (if (listp first)
         (let ((condition (car first))
               (body (cdr first)))
           (if (null body)
               (let ((temp (make-symbol "cond-temp")))
                 `(let ((,temp ,condition))
                    (declare (lexical ,temp))
                    (if ,temp
                        ,temp
                      (cond ,@rest))))
             `(if ,condition
                  (progn ,@body)
                (cond ,@rest))))
       (signal 'wrong-type-argument `(listp ,first))))))

(defmacro and (&rest conditions)
  (cond ((null conditions) t)
        ((null (cdr conditions)) (car conditions))
        (t `(if ,(car conditions)
                (and ,@(cdr conditions))
              nil))))

(defmacro or (&rest conditions)
  (cond ((null conditions) nil)
        ((null (cdr conditions)) (car conditions))
        (t (let ((temp (make-symbol "or-temp")))
             `(let ((,temp ,(car conditions)))
                (declare (lexical ,temp))
                (if ,temp
                    ,temp
                  (or ,@(cdr conditions))))))))

(defmacro lexical-let (bindings &rest body)
  (labels ((loop (list vars)
             (if (null list)
                 `(let ,bindings
                    (declare (lexical ,@vars))
                    ,@body)
               (loop (cdr list)
                     (if (consp (car list))
                         `(,(car (car list)) ,@vars)
                       `(,(car list) ,@vars))))))
    (loop bindings '())))

(defmacro lexical-let* (bindings &rest body)
  (labels ((loop (list vars)
             (if (null list)
                 `(let* ,bindings
                    (declare (lexical ,@vars))
                    ,@body)
               (loop (cdr list)
                     (if (consp (car list))
                         (cons (car (car list)) vars)
                       (cons (car list) vars))))))
    (loop bindings '())))

(defmacro while (test &rest body)
  (let ((loop (make-symbol "loop")))
    `(labels ((,loop ()
                 (if ,test
                     (progn ,@body (,loop))
                   nil)))
       (,loop))))

(defmacro catch (tag &rest body)
  (let* ((temp (make-symbol "catch-temp"))
         (elisp-key (make-symbol "catch-elisp-key"))
         (key (make-symbol "catch-key"))
         (value (make-symbol "catch-value")))
    `(let ((,temp ,tag))
       (declare (lexical ,temp))
       (funcall (@ (guile) catch)
                'elisp-exception
                #'(lambda () ,@body)
                #'(lambda (,key ,elisp-key ,value)
                    (if (eq ,elisp-key ,temp)
                        ,value
                      (funcall (@ (guile) throw)
                               ,key
                               ,elisp-key
                               ,value)))))))

(defmacro unwind-protect (bodyform &rest unwindforms)
  `(funcall (@ (guile) dynamic-wind)
            #'(lambda () nil)
            #'(lambda () ,bodyform)
            #'(lambda () ,@unwindforms)))

(defun symbolp (object)
  (%funcall (@ (guile) symbol?) object))

(defun functionp (object)
  (%funcall (@ (guile) procedure?) object))

(defun symbol-function (symbol)
  (let ((f (%funcall (@ (language elisp runtime) symbol-function)
                     symbol)))
    (if (%funcall (@ (language elisp falias) falias?) f)
        (%funcall (@ (language elisp falias) falias-object) f)
      f)))

(defun eval (form)
  (%funcall (@ (system base compile) compile)
            form
            (%funcall (@ (guile) symbol->keyword) 'from)
            'elisp
            (%funcall (@ (guile) symbol->keyword) 'to)
            'value))

(defun %indirect-function (object)
  (cond
   ((functionp object)
    object)
   ((symbolp object)                    ;++ cycle detection
    (%indirect-function (symbol-function object)))
   ((listp object)
    (eval `(function ,object)))
   (t
    (signal 'invalid-function `(,object)))))

(defun apply (function &rest arguments)
  (%funcall (@ (guile) apply)
            (@ (guile) apply)
            (%indirect-function function)
            arguments))

(defun funcall (function &rest arguments)
  (%funcall (@ (guile) apply)
            (%indirect-function function)
            arguments))

(defun fset (symbol definition)
  (funcall (@ (language elisp runtime) set-symbol-function!)
           symbol
           (if (functionp definition)
               definition
             (funcall (@ (language elisp falias) make-falias)
                      #'(lambda (&rest args) (apply definition args))
                      definition)))
  definition)

(defun throw (tag value)
  (funcall (@ (guile) throw) 'elisp-exception tag value))

(defun load (file)
  (funcall (@ (system base compile) compile-file)
           file
           (funcall (@ (guile) symbol->keyword) 'from)
           'elisp
           (funcall (@ (guile) symbol->keyword) 'to)
           'value)
  t)

;;; Equality predicates

(defun eq (obj1 obj2)
  (if obj1
      (funcall (@ (guile) eq?) obj1 obj2)
    (null obj2)))

(defun eql (obj1 obj2)
  (if obj1
      (funcall (@ (guile) eqv?) obj1 obj2)
    (null obj2)))

(defun equal (obj1 obj2)
  (if obj1
      (funcall (@ (guile) equal?) obj1 obj2)
    (null obj2)))

;;; Symbols

;;; `symbolp' and `symbol-function' are defined above.

(fset 'symbol-value (@ (language elisp runtime) symbol-value))
(fset 'set (@ (language elisp runtime) set-symbol-value!))
(fset 'makunbound (@ (language elisp runtime) makunbound!))
(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
(fset 'boundp (@ (language elisp runtime) symbol-bound?))
(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))

(defun defvaralias (new-alias base-variable &optional docstring)
  (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
                        base-variable)))
    (funcall (@ (language elisp runtime) set-symbol-fluid!)
             new-alias
             fluid)
    base-variable))

;;; Numerical type predicates

(defun floatp (object)
  (and (funcall (@ (guile) real?) object)
       (or (funcall (@ (guile) inexact?) object)
           (null (funcall (@ (guile) integer?) object)))))

(defun integerp (object)
  (and (funcall (@ (guile) exact?) object)
       (funcall (@ (guile) integer?) object)))

(defun numberp (object)
  (funcall (@ (guile) real?) object))

(defun wholenump (object)
  (and (funcall (@ (guile) exact?) object)
       (funcall (@ (guile) integer?) object)
       (>= object 0)))

(defun zerop (object)
  (= object 0))

;;; Numerical comparisons

(fset '= (@ (guile) =))

(defun /= (num1 num2)
  (null (= num1 num2)))

(fset '< (@ (guile) <))
(fset '<= (@ (guile) <=))
(fset '> (@ (guile) >))
(fset '>= (@ (guile) >=))

(defun max (&rest numbers)
  (apply (@ (guile) max) numbers))

(defun min (&rest numbers)
  (apply (@ (guile) min) numbers))

;;; Arithmetic functions

(fset '1+ (@ (guile) 1+))
(fset '1- (@ (guile) 1-))
(fset '+ (@ (guile) +))
(fset '- (@ (guile) -))
(fset '* (@ (guile) *))
(fset '% (@ (guile) modulo))
(fset 'abs (@ (guile) abs))

;;; Floating-point rounding

(fset 'ffloor (@ (guile) floor))
(fset 'fceiling (@ (guile) ceiling))
(fset 'ftruncate (@ (guile) truncate))
(fset 'fround (@ (guile) round))

;;; Numeric conversion

(defun float (arg)
  (if (numberp arg)
      (funcall (@ (guile) exact->inexact) arg)
    (signal 'wrong-type-argument `(numberp ,arg))))

;;; List predicates

(fset 'not #'null)

(defun atom (object)
  (null (consp object)))

(defun nlistp (object)
  (null (listp object)))

;;; Lists

(fset 'cons (@ (guile) cons))
(fset 'list (@ (guile) list))
(fset 'make-list (@ (guile) make-list))
(fset 'append (@ (guile) append))
(fset 'reverse (@ (guile) reverse))

(defun car-safe (object)
  (if (consp object)
      (car object)
    nil))

(defun cdr-safe (object)
  (if (consp object)
      (cdr object)
    nil))

(defun setcar (cell newcar)
  (if (consp cell)
      (progn
        (funcall (@ (guile) set-car!) cell newcar)
        newcar)
    (signal 'wrong-type-argument `(consp ,cell))))

(defun setcdr (cell newcdr)
  (if (consp cell)
      (progn
        (funcall (@ (guile) set-cdr!) cell newcdr)
        newcdr)
    (signal 'wrong-type-argument `(consp ,cell))))

(defun nthcdr (n list)
  (let ((i 0))
    (while (< i n)
      (setq list (cdr list)
            i (+ i 1)))
    list))

(defun nth (n list)
  (car (nthcdr n list)))

(defun %member (elt list test)
  (cond
   ((null list) nil)
   ((consp list)
    (if (funcall test elt (car list))
        list
      (%member elt (cdr list) test)))
   (t (signal 'wrong-type-argument `(listp ,list)))))

(defun member (elt list)
  (%member elt list #'equal))

(defun memql (elt list)
  (%member elt list #'eql))

(defun memq (elt list)
  (%member elt list #'eq))

;;; Strings

(defun string (&rest characters)
  (funcall (@ (guile) list->string)
           (mapcar (@ (guile) integer->char) characters)))

;;; Sequences

(fset 'length (@ (guile) length))

(defun mapcar (function sequence)
  (funcall (@ (guile) map) function sequence))

;;; Property lists

(defun %plist-member (plist property test)
  (catch 'loop
    (while plist
      (if (funcall test (car plist) property)
          (throw 'loop (cdr plist))
        (setq plist (cddr plist))))))

(defun %plist-get (plist property test)
  (car (%plist-member plist property test)))

(defun %plist-put (plist property value test)
  (let ((x (%plist-member plist property test)))
    (if x
        (progn (setcar x value) plist)
      (cons property (cons value plist)))))

(defun plist-get (plist property)
  (%plist-get plist property #'eq))

(defun plist-put (plist property value)
  (%plist-put plist property value #'eq))

(defun plist-member (plist property)
  (%plist-member plist property #'eq))

(defun lax-plist-get (plist property)
  (%plist-get plist property #'equal))

(defun lax-plist-put (plist property value)
  (%plist-put plist property value #'equal))

(defvar plist-function (funcall (@ (guile) make-object-property)))

(defun symbol-plist (symbol)
  (funcall plist-function symbol))

(defun setplist (symbol plist)
  (funcall (funcall (@ (guile) setter) plist-function) symbol plist))

(defun get (symbol propname)
  (plist-get (symbol-plist symbol) propname))

(defun put (symbol propname value)
  (setplist symbol (plist-put (symbol-plist symbol) propname value)))
Commit	Line	Data
ddc9006b	1	;;; Guile Emacs Lisp -- lexical-binding: t --
6937c7aa BT	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:
9b15703d BT	21
	22	(defmacro @ (module symbol)
	23	`(guile-ref ,module ,symbol))
	24
b652e2b9 BT	25	(defmacro eval-and-compile (&rest body)
	26	`(progn
	27	(eval-when-compile ,@body)
	28	(progn ,@body)))
	29
	30	(eval-and-compile
b652e2b9 BT	31	(defun null (object)
b652e2b9 BT	32	(if object nil t))
b05ca4ab BT	33	(defun consp (object)
b05ca4ab BT	34	(%funcall (@ (guile) pair?) object))
b652e2b9 BT	35	(defun listp (object)
	36	(if object (consp object) t))
	37	(defun car (list)
b05ca4ab	38	(if list (%funcall (@ (guile) car) list) nil))
b652e2b9	39	(defun cdr (list)
b05ca4ab BT	40	(if list (%funcall (@ (guile) cdr) list) nil))
	41	(defun make-symbol (name)
	42	(%funcall (@ (guile) make-symbol) name))
b652e2b9	43	(defun signal (&rest args)
b05ca4ab	44	(%funcall (@ (guile) throw) 'elisp-error args)))
b652e2b9 BT	45
	46	(defmacro lambda (&rest cdr)
	47	`#'(lambda ,@cdr))
	48
	49	(defmacro prog1 (first &rest body)
	50	(let ((temp (make-symbol "prog1-temp")))
13f022c9 BT	51	`(let ((,temp ,first))
13f022c9 BT	52	(declare (lexical ,temp))
b652e2b9 BT	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")))
13f022c9 BT	69	`(let ((,temp ,condition))
13f022c9 BT	70	(declare (lexical ,temp))
b652e2b9 BT	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")))
13f022c9 BT	90	`(let ((,temp ,(car conditions)))
13f022c9 BT	91	(declare (lexical ,temp))
b652e2b9 BT	92	(if ,temp
	93	,temp
	94	(or ,@(cdr conditions))))))))
	95
9083c48d BT	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
9b90b453 BT	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
b652e2b9 BT	128	(defmacro catch (tag &rest body)
	129	(let* ((temp (make-symbol "catch-temp"))
	130	(elisp-key (make-symbol "catch-elisp-key"))
5fa5bf7d	131	(key (make-symbol "catch-key"))
b652e2b9	132	(value (make-symbol "catch-value")))
13f022c9 BT	133	`(let ((,temp ,tag))
13f022c9 BT	134	(declare (lexical ,temp))
b652e2b9	135	(funcall (@ (guile) catch)
5fa5bf7d	136	'elisp-exception
b652e2b9	137	#'(lambda () ,@body)
5fa5bf7d	138	#'(lambda (,key ,elisp-key ,value)
b652e2b9 BT	139	(if (eq ,elisp-key ,temp)
	140	,value
	141	(funcall (@ (guile) throw)
5fa5bf7d	142	,key
b652e2b9 BT	143	,elisp-key
	144	,value)))))))
	145
	146	(defmacro unwind-protect (bodyform &rest unwindforms)
	147	`(funcall (@ (guile) dynamic-wind)
	148	#'(lambda () nil)
	149	#'(lambda () ,bodyform)
	150	#'(lambda () ,@unwindforms)))
9b15703d	151
b05ca4ab BT	152	(defun symbolp (object)
	153	(%funcall (@ (guile) symbol?) object))
	154
	155	(defun functionp (object)
	156	(%funcall (@ (guile) procedure?) object))
	157
	158	(defun symbol-function (symbol)
	159	(let ((f (%funcall (@ (language elisp runtime) symbol-function)
	160	symbol)))
	161	(if (%funcall (@ (language elisp falias) falias?) f)
	162	(%funcall (@ (language elisp falias) falias-object) f)
	163	f)))
97d9da9a	164
5bcc6d9e	165	(defun eval (form)
b05ca4ab BT	166	(%funcall (@ (system base compile) compile)
	167	form
	168	(%funcall (@ (guile) symbol->keyword) 'from)
	169	'elisp
	170	(%funcall (@ (guile) symbol->keyword) 'to)
	171	'value))
	172
	173	(defun %indirect-function (object)
	174	(cond
	175	((functionp object)
	176	object)
	177	((symbolp object) ;++ cycle detection
	178	(%indirect-function (symbol-function object)))
	179	((listp object)
	180	(eval `(function ,object)))
	181	(t
	182	(signal 'invalid-function `(,object)))))
	183
	184	(defun apply (function &rest arguments)
	185	(%funcall (@ (guile) apply)
	186	(@ (guile) apply)
	187	(%indirect-function function)
	188	arguments))
	189
	190	(defun funcall (function &rest arguments)
	191	(%funcall (@ (guile) apply)
	192	(%indirect-function function)
	193	arguments))
	194
	195	(defun fset (symbol definition)
	196	(funcall (@ (language elisp runtime) set-symbol-function!)
	197	symbol
	198	(if (functionp definition)
	199	definition
	200	(funcall (@ (language elisp falias) make-falias)
	201	#'(lambda (&rest args) (apply definition args))
	202	definition)))
	203	definition)
	204
	205	(defun throw (tag value)
	206	(funcall (@ (guile) throw) 'elisp-exception tag value))
5bcc6d9e BT	207
	208	(defun load (file)
	209	(funcall (@ (system base compile) compile-file)
	210	file
	211	(funcall (@ (guile) symbol->keyword) 'from)
	212	'elisp
	213	(funcall (@ (guile) symbol->keyword) 'to)
	214	'value)
	215	t)
	216
9b15703d BT	217	;;; Equality predicates
9b15703d BT	218
0ab2a63a BT	219	(defun eq (obj1 obj2)
	220	(if obj1
	221	(funcall (@ (guile) eq?) obj1 obj2)
	222	(null obj2)))
	223
	224	(defun eql (obj1 obj2)
	225	(if obj1
	226	(funcall (@ (guile) eqv?) obj1 obj2)
	227	(null obj2)))
	228
	229	(defun equal (obj1 obj2)
	230	(if obj1
	231	(funcall (@ (guile) equal?) obj1 obj2)
	232	(null obj2)))
9b15703d	233
85bc6238 BT	234	;;; Symbols
85bc6238 BT	235
b05ca4ab BT	236	;;; `symbolp' and `symbol-function' are defined above.
b05ca4ab BT	237
85bc6238	238	(fset 'symbol-value (@ (language elisp runtime) symbol-value))
85bc6238 BT	239	(fset 'set (@ (language elisp runtime) set-symbol-value!))
	240	(fset 'makunbound (@ (language elisp runtime) makunbound!))
	241	(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
	242	(fset 'boundp (@ (language elisp runtime) symbol-bound?))
	243	(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
	244
14b288ce BT	245	(defun defvaralias (new-alias base-variable &optional docstring)
	246	(let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
	247	base-variable)))
	248	(funcall (@ (language elisp runtime) set-symbol-fluid!)
	249	new-alias
	250	fluid)
	251	base-variable))
	252
9b15703d BT	253	;;; Numerical type predicates
	254
	255	(defun floatp (object)
	256	(and (funcall (@ (guile) real?) object)
	257	(or (funcall (@ (guile) inexact?) object)
	258	(null (funcall (@ (guile) integer?) object)))))
	259
	260	(defun integerp (object)
	261	(and (funcall (@ (guile) exact?) object)
	262	(funcall (@ (guile) integer?) object)))
	263
	264	(defun numberp (object)
	265	(funcall (@ (guile) real?) object))
	266
	267	(defun wholenump (object)
	268	(and (funcall (@ (guile) exact?) object)
	269	(funcall (@ (guile) integer?) object)
	270	(>= object 0)))
	271
	272	(defun zerop (object)
	273	(= object 0))
	274
	275	;;; Numerical comparisons
	276
	277	(fset '= (@ (guile) =))
	278
	279	(defun /= (num1 num2)
	280	(null (= num1 num2)))
	281
	282	(fset '< (@ (guile) <))
	283	(fset '<= (@ (guile) <=))
	284	(fset '> (@ (guile) >))
	285	(fset '>= (@ (guile) >=))
	286
	287	(defun max (&rest numbers)
	288	(apply (@ (guile) max) numbers))
	289
	290	(defun min (&rest numbers)
	291	(apply (@ (guile) min) numbers))
	292
	293	;;; Arithmetic functions
	294
	295	(fset '1+ (@ (guile) 1+))
	296	(fset '1- (@ (guile) 1-))
	297	(fset '+ (@ (guile) +))
	298	(fset '- (@ (guile) -))
	299	(fset '* (@ (guile) *))
	300	(fset '% (@ (guile) modulo))
	301	(fset 'abs (@ (guile) abs))
	302
	303	;;; Floating-point rounding
	304
	305	(fset 'ffloor (@ (guile) floor))
	306	(fset 'fceiling (@ (guile) ceiling))
	307	(fset 'ftruncate (@ (guile) truncate))
	308	(fset 'fround (@ (guile) round))
	309
	310	;;; Numeric conversion
	311
	312	(defun float (arg)
	313	(if (numberp arg)
	314	(funcall (@ (guile) exact->inexact) arg)
	315	(signal 'wrong-type-argument `(numberp ,arg))))
	316
317	;;; List predicates
318
9b15703d BT	319	(fset 'not #'null)
	320
	321	(defun atom (object)
	322	(null (consp object)))
	323
9b15703d BT	324	(defun nlistp (object)
	325	(null (listp object)))
	326
	327	;;; Lists
	328
	329	(fset 'cons (@ (guile) cons))
	330	(fset 'list (@ (guile) list))
	331	(fset 'make-list (@ (guile) make-list))
	332	(fset 'append (@ (guile) append))
	333	(fset 'reverse (@ (guile) reverse))
	334
9b15703d BT	335	(defun car-safe (object)
	336	(if (consp object)
	337	(car object)
	338	nil))
	339
	340	(defun cdr-safe (object)
	341	(if (consp object)
	342	(cdr object)
	343	nil))
	344
	345	(defun setcar (cell newcar)
	346	(if (consp cell)
	347	(progn
	348	(funcall (@ (guile) set-car!) cell newcar)
	349	newcar)
	350	(signal 'wrong-type-argument `(consp ,cell))))
	351
	352	(defun setcdr (cell newcdr)
	353	(if (consp cell)
	354	(progn
	355	(funcall (@ (guile) set-cdr!) cell newcdr)
	356	newcdr)
	357	(signal 'wrong-type-argument `(consp ,cell))))
	358
	359	(defun nthcdr (n list)
	360	(let ((i 0))
	361	(while (< i n)
	362	(setq list (cdr list)
	363	i (+ i 1)))
	364	list))
	365
	366	(defun nth (n list)
	367	(car (nthcdr n list)))
	368
df9cd3b4 BT	369	(defun %member (elt list test)
	370	(cond
	371	((null list) nil)
	372	((consp list)
	373	(if (funcall test elt (car list))
	374	list
	375	(%member elt (cdr list) test)))
	376	(t (signal 'wrong-type-argument `(listp ,list)))))
	377
	378	(defun member (elt list)
	379	(%member elt list #'equal))
	380
	381	(defun memql (elt list)
	382	(%member elt list #'eql))
	383
	384	(defun memq (elt list)
	385	(%member elt list #'eq))
	386
8f2f6566 BT	387	;;; Strings
	388
	389	(defun string (&rest characters)
	390	(funcall (@ (guile) list->string)
	391	(mapcar (@ (guile) integer->char) characters)))
	392
9b15703d BT	393	;;; Sequences
	394
	395	(fset 'length (@ (guile) length))
8f2f6566 BT	396
	397	(defun mapcar (function sequence)
	398	(funcall (@ (guile) map) function sequence))
12ca82ca BT	399
	400	;;; Property lists
	401
	402	(defun %plist-member (plist property test)
	403	(catch 'loop
	404	(while plist
	405	(if (funcall test (car plist) property)
	406	(throw 'loop (cdr plist))
	407	(setq plist (cddr plist))))))
	408
	409	(defun %plist-get (plist property test)
	410	(car (%plist-member plist property test)))
	411
	412	(defun %plist-put (plist property value test)
13f022c9	413	(let ((x (%plist-member plist property test)))
12ca82ca BT	414	(if x
	415	(progn (setcar x value) plist)
	416	(cons property (cons value plist)))))
	417
	418	(defun plist-get (plist property)
	419	(%plist-get plist property #'eq))
	420
	421	(defun plist-put (plist property value)
	422	(%plist-put plist property value #'eq))
	423
	424	(defun plist-member (plist property)
	425	(%plist-member plist property #'eq))
	426
	427	(defun lax-plist-get (plist property)
	428	(%plist-get plist property #'equal))
	429
	430	(defun lax-plist-put (plist property value)
	431	(%plist-put plist property value #'equal))
	432
	433	(defvar plist-function (funcall (@ (guile) make-object-property)))
	434
	435	(defun symbol-plist (symbol)
	436	(funcall plist-function symbol))
	437
	438	(defun setplist (symbol plist)
	439	(funcall (funcall (@ (guile) setter) plist-function) symbol plist))
	440
	441	(defun get (symbol propname)
	442	(plist-get (symbol-plist symbol) propname))
	443
	444	(defun put (symbol propname value)
	445	(setplist symbol (plist-put (symbol-plist symbol) propname value)))