ikarus/src/ikarus.pairs.ss

(library (ikarus pairs)
  (export
    cons weak-cons set-car! set-cdr!
    car cdr caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr
    caddr cdddr caaaar cdaaar cadaar cddaar caadar cdadar caddar
    cdddar caaadr cdaadr cadadr cddadr caaddr cdaddr cadddr cddddr)
  (import 
    (only (ikarus) define if lambda pair? error quote let unless
          foreign-call)
    (rename (only (scheme) cons $car $cdr $set-car! $set-cdr!)
            (cons sys:cons)))

  (define cons (lambda (x y) (sys:cons x y)))

  (define weak-cons
    (lambda (a d)
      (foreign-call "ikrt_weak_cons" a d)))

  (define set-car!
    (lambda (x y) 
      (unless (pair? x)
        (error 'set-car! "~s is not a pair" x))
      ($set-car! x y)))
  
  (define set-cdr! 
    (lambda (x y)
      (unless (pair? x)
        (error 'set-cdr! "~s is not a pair" x))
      ($set-cdr! x y)))

  (define err
    (lambda (who x)
      (error who "invalid list structure ~s" x)))
  (define car
    (lambda (orig)
      (if (pair? orig) ($car orig) (err 'car orig))))
  (define cdr
    (lambda (orig)
      (if (pair? orig) ($cdr orig) (err 'cdr orig))))
  (define caar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x) ($car x) (err 'caar orig)))
          (err 'caar orig))))
  (define cadr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x) ($car x) (err 'cadr orig)))
          (err 'cadr orig))))
  (define cdar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x) ($cdr x) (err 'cdar orig)))
          (err 'cdar orig))))
  (define cddr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x) ($cdr x) (err 'cddr orig)))
          (err 'cddr orig))))
  (define caaar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x) ($car x) (err 'caaar orig)))
                (err 'caaar orig)))
          (err 'caaar orig))))
  (define caadr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x) ($car x) (err 'caadr orig)))
                (err 'caadr orig)))
          (err 'caadr orig))))
  (define cadar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x) ($car x) (err 'cadar orig)))
                (err 'cadar orig)))
          (err 'cadar orig))))
  (define caddr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x) ($car x) (err 'caddr orig)))
                (err 'caddr orig)))
          (err 'caddr orig))))
  (define cdaar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x) ($cdr x) (err 'cdaar orig)))
                (err 'cdaar orig)))
          (err 'cdaar orig))))
  (define cdadr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x) ($cdr x) (err 'cdadr orig)))
                (err 'cdadr orig)))
          (err 'cdadr orig))))
  (define cddar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x) ($cdr x) (err 'cddar orig)))
                (err 'cddar orig)))
          (err 'cddar orig))))
  (define cdddr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x) ($cdr x) (err 'cdddr orig)))
                (err 'cdddr orig)))
          (err 'cdddr orig))))
  (define caaaar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($car x) (err 'caaaar orig)))
                      (err 'caaaar orig)))
                (err 'caaaar orig)))
          (err 'caaaar orig))))
  (define caaadr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($car x) (err 'caaadr orig)))
                      (err 'caaadr orig)))
                (err 'caaadr orig)))
          (err 'caaadr orig))))
  (define caadar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($car x) (err 'caadar orig)))
                      (err 'caadar orig)))
                (err 'caadar orig)))
          (err 'caadar orig))))
  (define caaddr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($car x) (err 'caaddr orig)))
                      (err 'caaddr orig)))
                (err 'caaddr orig)))
          (err 'caaddr orig))))
  (define cadaar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($car x) (err 'cadaar orig)))
                      (err 'cadaar orig)))
                (err 'cadaar orig)))
          (err 'cadaar orig))))
  (define cadadr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($car x) (err 'cadadr orig)))
                      (err 'cadadr orig)))
                (err 'cadadr orig)))
          (err 'cadadr orig))))
  (define caddar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($car x) (err 'caddar orig)))
                      (err 'caddar orig)))
                (err 'caddar orig)))
          (err 'caddar orig))))
  (define cadddr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($car x) (err 'cadddr orig)))
                      (err 'cadddr orig)))
                (err 'cadddr orig)))
          (err 'cadddr orig))))
  (define cdaaar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($cdr x) (err 'cdaaar orig)))
                      (err 'cdaaar orig)))
                (err 'cdaaar orig)))
          (err 'cdaaar orig))))
  (define cdaadr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($cdr x) (err 'cdaadr orig)))
                      (err 'cdaadr orig)))
                (err 'cdaadr orig)))
          (err 'cdaadr orig))))
  (define cdadar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($cdr x) (err 'cdadar orig)))
                      (err 'cdadar orig)))
                (err 'cdadar orig)))
          (err 'cdadar orig))))
  (define cdaddr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($car x)])
                        (if (pair? x) ($cdr x) (err 'cdaddr orig)))
                      (err 'cdaddr orig)))
                (err 'cdaddr orig)))
          (err 'cdaddr orig))))
  (define cddaar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($cdr x) (err 'cddaar orig)))
                      (err 'cddaar orig)))
                (err 'cddaar orig)))
          (err 'cddaar orig))))
  (define cddadr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($car x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($cdr x) (err 'cddadr orig)))
                      (err 'cddadr orig)))
                (err 'cddadr orig)))
          (err 'cddadr orig))))
  (define cdddar
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($car orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($cdr x) (err 'cdddar orig)))
                      (err 'cdddar orig)))
                (err 'cdddar orig)))
          (err 'cdddar orig))))
  (define cddddr
    (lambda (orig)
      (if (pair? orig)
          (let ([x ($cdr orig)])
            (if (pair? x)
                (let ([x ($cdr x)])
                  (if (pair? x)
                      (let ([x ($cdr x)])
                        (if (pair? x) ($cdr x) (err 'cddddr orig)))
                      (err 'cddddr orig)))
                (err 'cddddr orig)))
          (err 'cddddr orig)))))