summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDaniel Kraft <d@domob.eu>2009-07-18 20:10:24 +0200
committerDaniel Kraft <d@domob.eu>2009-07-18 20:10:24 +0200
commitf614ca12cd83aaec77096aed9671aaa0bd51b695 (patch)
treed43c83f97f248ba4f8d26cda56d883713f32ed36
parent7d1a978289c75efbb99684c4feb29dfb10cf1229 (diff)
downloadguile-f614ca12cd83aaec77096aed9671aaa0bd51b695.tar.gz
Implemented some important list built-ins.
* module/language/elisp/runtime.scm: Updated/added convenience macros. * module/language/elisp/runtime/function-slot.scm: Implement list built-ins. * module/language/elisp/runtime/macro-slot.scm: Implement list built-ins. * test-suite/tests/elisp-compiler.test: Test the implemented built-ins.
-rw-r--r--module/language/elisp/runtime.scm17
-rw-r--r--module/language/elisp/runtime/function-slot.scm149
-rw-r--r--module/language/elisp/runtime/macro-slot.scm12
-rw-r--r--test-suite/tests/elisp-compiler.test74
4 files changed, 235 insertions, 17 deletions
diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm
index 2bdadf9b4..1ec5bb4c1 100644
--- a/module/language/elisp/runtime.scm
+++ b/module/language/elisp/runtime.scm
@@ -20,8 +20,8 @@
;;; Code:
(define-module (language elisp runtime)
- #:export (void nil-value t-value elisp-bool macro-error)
- #:export-syntax (built-in-func built-in-macro))
+ #:export (void nil-value t-value elisp-bool runtime-error macro-error)
+ #:export-syntax (built-in-func built-in-macro prim))
; This module provides runtime support for the Elisp front-end.
@@ -39,11 +39,13 @@
; Report an error during macro compilation, that means some special compilation
-; (syntax) error.
+; (syntax) error; or report a simple runtime-error from a built-in function.
(define (macro-error msg . args)
(apply error msg args))
+(define runtime-error macro-error)
+
; Convert a scheme boolean to Elisp.
@@ -67,3 +69,12 @@
(syntax-rules ()
((_ name value)
(define-public name value))))
+
+
+; Call a guile-primitive that may be rebound for elisp and thus needs absolute
+; addressing.
+
+(define-syntax prim
+ (syntax-rules ()
+ ((_ sym args ...)
+ ((@ (guile) sym) args ...))))
diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm
index db751d2e7..3b3cf3c8d 100644
--- a/module/language/elisp/runtime/function-slot.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -40,8 +40,7 @@
(built-in-func floatp (lambda (num)
(elisp-bool (and (real? num)
(or (inexact? num)
- ((@ (guile) not)
- (integer? num)))))))
+ (prim not (integer? num)))))))
(built-in-func integerp (lambda (num)
(elisp-bool (and (exact? num)
@@ -53,35 +52,34 @@
(built-in-func wholenump (lambda (num)
(elisp-bool (and (exact? num)
(integer? num)
- ((@ (guile) >=) num 0)))))
+ (prim >= num 0)))))
(built-in-func zerop (lambda (num)
- (elisp-bool ((@ (guile) =) num 0))))
+ (elisp-bool (prim = num 0))))
; Number comparisons.
(built-in-func = (lambda (num1 num2)
- (elisp-bool ((@ (guile) =) num1 num2))))
+ (elisp-bool (prim = num1 num2))))
(built-in-func /= (lambda (num1 num2)
- (elisp-bool ((@ (guile) not) ((@ (guile) =) num1 num2)))))
+ (elisp-bool (prim not (prim = num1 num2)))))
(built-in-func < (lambda (num1 num2)
- (elisp-bool ((@ (guile) <) num1 num2))))
+ (elisp-bool (prim < num1 num2))))
(built-in-func <= (lambda (num1 num2)
- (elisp-bool ((@ (guile) <=) num1 num2))))
+ (elisp-bool (prim <= num1 num2))))
(built-in-func > (lambda (num1 num2)
- (elisp-bool ((@ (guile) >) num1 num2))))
+ (elisp-bool (prim > num1 num2))))
(built-in-func >= (lambda (num1 num2)
- (elisp-bool ((@ (guile) >=) num1 num2))))
+ (elisp-bool (prim >= num1 num2))))
(built-in-func max (lambda (. nums)
- ((@ (guile) apply) (@ (guile) max) nums)))
+ (prim apply (@ (guile) max) nums)))
(built-in-func min (lambda (. nums)
- ((@ (guile) apply) (@ (guile) min) nums)))
+ (prim apply (@ (guile) min) nums)))
-(built-in-func abs (lambda (num)
- ((@ (guile) abs) num)))
+(built-in-func abs (@ (guile) abs))
; Number conversion.
@@ -114,6 +112,129 @@
(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))))))))
+
+
+; 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))
+
+
; Miscellaneous.
(built-in-func not (lambda (x)
diff --git a/module/language/elisp/runtime/macro-slot.scm b/module/language/elisp/runtime/macro-slot.scm
index 9d0477be9..9a4c52ca5 100644
--- a/module/language/elisp/runtime/macro-slot.scm
+++ b/module/language/elisp/runtime/macro-slot.scm
@@ -62,3 +62,15 @@
,@(if (= (length args) 3)
(list (caddr args))
'()))))))
+
+
+; Pop off the first element from a list or push one to it.
+
+(built-in-macro pop
+ (lambda (list-name)
+ `(prog1 (car ,list-name)
+ (setq ,list-name (cdr ,list-name)))))
+
+(built-in-macro push
+ (lambda (new-el list-name)
+ `(setq ,list-name (cons ,new-el ,list-name))))
diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test
index d36f47c77..43a34d7ec 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -332,3 +332,77 @@
(= (fceiling 1.2) 2.0) (= (fceiling -1.7) -1.0) (= (fceiling 1.0) 1.0)
(= (ftruncate 1.6) 1.0) (= (ftruncate -1.7) -1.0)
(= (fround 1.2) 1.0) (= (fround 1.7) 2.0) (= (fround -1.7) -2.0))))
+
+(with-test-prefix/compile "List Built-Ins"
+
+ (pass-if "consp and atomp"
+ (and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b))
+ (not (consp '())) (not (consp 1)) (not (consp "abc"))
+ (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc")
+ (not (atomp '(1 . 2))) (not (atomp '(1)))))
+ (pass-if "listp and nlistp"
+ (and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2))
+ (not (listp 'a)) (not (listp 42)) (nlistp 42)
+ (not (nlistp '())) (not (nlistp '(1 2 3))) (not (nlistp '(1 . 2)))))
+ (pass-if "null"
+ (and (null '()) (not (null 1)) (not (null '(1 2))) (not (null '(1 . 2)))))
+
+ (pass-if "car and cdr"
+ (and (equal (car '(1 2 3)) 1) (equal (cdr '(1 2 3)) '(2 3))
+ (equal (car '()) nil) (equal (cdr '()) nil)
+ (equal (car '(1 . 2)) 1) (equal (cdr '(1 . 2)) 2)
+ (null (cdr '(1)))))
+ (pass-if "car-safe and cdr-safe"
+ (and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2))
+ (equal (car-safe 5) nil) (equal (cdr-safe 5) nil)))
+
+ (pass-if "pop"
+ (progn (setq mylist '(a b c))
+ (setq value (pop mylist))
+ (and (equal value 'a)
+ (equal mylist '(b c)))))
+ (pass-if-equal "push" '(a b c)
+ (progn (setq mylist '(b c))
+ (push 'a mylist)))
+
+ (pass-if "nth and nthcdr"
+ (and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil)
+ (equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3)
+ (equal (nthcdr -5 '(1 2 3)) '(1 2 3))
+ (equal (nthcdr 4 '(1 2 3)) nil)
+ (equal (nthcdr 1 '(1 2 3)) '(2 3))
+ (equal (nthcdr 2 '(1 2 3)) '(3))))
+
+ (pass-if "cons, list and make-list"
+ (and (equal (cons 1 2) '(1 . 2)) (equal (cons 1 '(2 3)) '(1 2 3))
+ (equal (cons 1 '()) '(1))
+ (equal (list 'a) '(a)) (equal (list) '()) (equal (list 1 2) '(1 2))
+ (equal (make-list 3 42) '(42 42 42))
+ (equal (make-list 0 1) '())))
+ (pass-if "append"
+ (and (equal (append '(1 2) '(3 4) '(5)) '(1 2 3 4 5))
+ (equal (append '(1 2) 3) '(1 2 . 3))))
+ (pass-if "reverse"
+ (and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5))
+ (equal (reverse '()) '())))
+ (pass-if "copy-tree"
+ (progn (setq mylist '(1 2 (3 4)))
+ (and (not (eq mylist (copy-tree mylist)))
+ (equal mylist (copy-tree mylist)))))
+
+ (pass-if "number-sequence"
+ (and (equal (number-sequence 5) '(5))
+ (equal (number-sequence 5 9) '(5 6 7 8 9))
+ (equal (number-sequence 5 9 3) '(5 8))
+ (equal (number-sequence 5 1 -2) '(5 3 1))
+ (equal (number-sequence 5 8 -1) '())
+ (equal (number-sequence 5 1) '())
+ (equal (number-sequence 5 5 0) '(5))))
+
+ (pass-if "setcar and setcdr"
+ (progn (setq pair '(1 . 2))
+ (setq copy pair)
+ (setq a (setcar copy 3))
+ (setq b (setcdr copy 4))
+ (and (= a 3) (= b 4)
+ (equal pair '(3 . 4))))))