← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to lang/elisp/primitives/lists.scm

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
lang/elisp/primitives/lists.scm
 
1
(define-module (lang elisp primitives lists)
 
2
  #:use-module (lang elisp internals fset)
 
3
  #:use-module (lang elisp internals null)
 
4
  #:use-module (lang elisp internals signal))
 
5
 
 
6
(fset 'cons cons)
 
7
 
 
8
(fset 'null null)
 
9
 
 
10
(fset 'not null)
 
11
 
 
12
(fset 'car
 
13
      (lambda (l)
 
14
        (if (null l)
 
15
            %nil
 
16
            (car l))))
 
17
 
 
18
(fset 'cdr
 
19
      (lambda (l)
 
20
        (if (null l)
 
21
            %nil
 
22
            (cdr l))))
 
23
 
 
24
(fset 'eq
 
25
      (lambda (x y)
 
26
        (or (eq? x y)
 
27
            (and (null x) (null y)))))
 
28
 
 
29
(fset 'equal
 
30
      (lambda (x y)
 
31
        (or (equal? x y)
 
32
            (and (null x) (null y)))))
 
33
 
 
34
(fset 'setcar set-car!)
 
35
 
 
36
(fset 'setcdr set-cdr!)
 
37
 
 
38
(for-each (lambda (sym proc)
 
39
            (fset sym
 
40
                  (lambda (elt list)
 
41
                    (if (null list)
 
42
                        %nil
 
43
                        (if (null elt)
 
44
                            (let loop ((l list))
 
45
                              (cond ((null l) %nil)
 
46
                                    ((null (car l)) l)
 
47
                                    (else (loop (cdr l)))))
 
48
                            (proc elt list))))))
 
49
          '( memq  member  assq  assoc)
 
50
          `(,memq ,member ,assq ,assoc))
 
51
 
 
52
(fset 'length
 
53
      (lambda (x)
 
54
        (cond ((null x) 0)
 
55
              ((pair? x) (length x))
 
56
              ((vector? x) (vector-length x))
 
57
              ((string? x) (string-length x))
 
58
              (else (wta 'sequencep x 1)))))
 
59
 
 
60
(fset 'copy-sequence
 
61
      (lambda (x)
 
62
        (cond ((list? x) (list-copy x))
 
63
              ((vector? x) (error "Vector copy not yet implemented"))
 
64
              ((string? x) (string-copy x))
 
65
              (else (wta 'sequencep x 1)))))
 
66
 
 
67
(fset 'elt
 
68
      (lambda (obj i)
 
69
        (cond ((pair? obj) (list-ref obj i))
 
70
              ((vector? obj) (vector-ref obj i))
 
71
              ((string? obj) (char->integer (string-ref obj i))))))
 
72
 
 
73
(fset 'list list)
 
74
 
 
75
(fset 'mapcar
 
76
      (lambda (function sequence)
 
77
        (map (lambda (elt)
 
78
               (elisp-apply function (list elt)))
 
79
             (cond ((null sequence) '())
 
80
                   ((list? sequence) sequence)
 
81
                   ((vector? sequence) (vector->list sequence))
 
82
                   ((string? sequence) (map char->integer (string->list sequence)))
 
83
                   (else (wta 'sequencep sequence 2))))))
 
84
 
 
85
(fset 'nth
 
86
      (lambda (n list)
 
87
        (if (or (null list)
 
88
                (>= n (length list)))
 
89
            %nil
 
90
            (list-ref list n))))
 
91
 
 
92
(fset 'listp
 
93
      (lambda (object)
 
94
        (or (null object)
 
95
            (list? object))))
 
96
 
 
97
(fset 'consp pair?)
 
98
 
 
99
(fset 'nconc
 
100
      (lambda args
 
101
        (apply append! (map (lambda (arg)
 
102
                              (if arg arg '()))
 
103
                            args))))