guile18/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))))