/[guile]/guile/guile-core/lang/elisp/primitives/lists.scm
ViewVC logotype

Diff of /guile/guile-core/lang/elisp/primitives/lists.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ossau, Fri Oct 26 16:42:43 2001 UTC revision 1.2 by ossau, Tue Jan 22 23:46:01 2002 UTC
# Line 0  Line 1 
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
7          (lambda (x y)
8            (cons x (or y '()))))
9    
10    (fset 'null null)
11    
12    (fset 'not null)
13    
14    (fset 'car
15          (lambda (l)
16            (if (null l)
17                #f
18                (car l))))
19    
20    (fset 'cdr
21          (lambda (l)
22            (if (null l)
23                #f
24                (cdr l))))
25    
26    (fset 'eq
27          (lambda (x y)
28            (or (eq? x y)
29                (and (null x) (null y)))))
30    
31    (fset 'equal
32          (lambda (x y)
33            (or (equal? x y)
34                (and (null x) (null y)))))
35    
36    (fset 'setcar set-car!)
37    
38    (fset 'setcdr
39          (lambda (cell newcdr)
40            (set-cdr! cell
41                      (if (null newcdr)
42                          '()
43                          newcdr))))
44    
45    (for-each (lambda (sym proc)
46                (fset sym
47                      (lambda (elt list)
48                        (if (null list)
49                            #f
50                            (if (null elt)
51                                (or (proc #f list)
52                                    (proc '() list))
53                                (proc elt list))))))
54              '( memq  member  assq  assoc)
55              `(,memq ,member ,assq ,assoc))
56    
57    (fset 'length
58          (lambda (x)
59            (cond ((null x) 0)
60                  ((pair? x) (length x))
61                  ((vector? x) (vector-length x))
62                  ((string? x) (string-length x))
63                  (else (wta 'sequencep x 1)))))
64    
65    (fset 'copy-sequence
66          (lambda (x)
67            (cond ((list? x) (list-copy x))
68                  ((vector? x) (error "Vector copy not yet implemented"))
69                  ((string? x) (string-copy x))
70                  (else (wta 'sequencep x 1)))))
71    
72    (fset 'elt
73          (lambda (obj i)
74            (cond ((pair? obj) (list-ref obj i))
75                  ((vector? obj) (vector-ref obj i))
76                  ((string? obj) (char->integer (string-ref obj i))))))
77    
78    (fset 'list list)
79    
80    (fset 'mapcar
81          (lambda (function sequence)
82            (map (lambda (elt)
83                   (elisp-apply function (list elt)))
84                 (cond ((null sequence) '())
85                       ((list? sequence) sequence)
86                       ((vector? sequence) (vector->list sequence))
87                       ((string? sequence) (map char->integer (string->list sequence)))
88                       (else (wta 'sequencep sequence 2))))))
89    
90    (fset 'nth
91          (lambda (n list)
92            (if (or (null list)
93                    (>= n (length list)))
94                #f
95                (list-ref list n))))
96    
97    (fset 'listp
98          (lambda (object)
99            (or (null object)
100                (list? object))))
101    
102    (fset 'consp pair?)
103    
104    (fset 'nconc
105          (lambda args
106            (apply append! (map (lambda (arg)
107                                  (if arg arg '()))
108                                args))))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26