diff options
author | Daniel Kraft <d@domob.eu> | 2009-07-18 20:10:24 +0200 |
---|---|---|
committer | Daniel Kraft <d@domob.eu> | 2009-07-18 20:10:24 +0200 |
commit | f614ca12cd83aaec77096aed9671aaa0bd51b695 (patch) | |
tree | d43c83f97f248ba4f8d26cda56d883713f32ed36 | |
parent | 7d1a978289c75efbb99684c4feb29dfb10cf1229 (diff) | |
download | guile-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.scm | 17 | ||||
-rw-r--r-- | module/language/elisp/runtime/function-slot.scm | 149 | ||||
-rw-r--r-- | module/language/elisp/runtime/macro-slot.scm | 12 | ||||
-rw-r--r-- | test-suite/tests/elisp-compiler.test | 74 |
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)))))) |