ikarus/scheme/ikarus.pairs.ss

105 lines
3.2 KiB
Scheme

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(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
(except (ikarus) 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)
(rename (only (ikarus) cons) (cons sys:cons))
(ikarus system $pairs))
(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)
(die 'set-car! "not a pair" x))
($set-car! x y)))
(define set-cdr!
(lambda (x y)
(unless (pair? x)
(die 'set-cdr! "not a pair" x))
($set-cdr! x y)))
(define-syntax cxr
(syntax-rules ()
[(_ err $car/$cdr)
(lambda (x)
(if (pair? x) ($car/$cdr x) err))]
[(_ err rest ... $car/$cdr)
(lambda (x)
(if (pair? x)
((cxr err rest ...) ($car/$cdr x))
err))]))
(define-syntax define-cxr*
(syntax-rules ()
[(_ [name* ops** ...] ...)
(begin
(define name*
(lambda (x)
((cxr (die 'name*
"argument does not have required pair structure" x)
ops** ...)
x)))
...)]))
(define-cxr*
[car $car]
[cdr $cdr]
[caar $car $car]
[cdar $cdr $car]
[cadr $car $cdr]
[cddr $cdr $cdr]
[caaar $car $car $car]
[cdaar $cdr $car $car]
[cadar $car $cdr $car]
[cddar $cdr $cdr $car]
[caadr $car $car $cdr]
[cdadr $cdr $car $cdr]
[caddr $car $cdr $cdr]
[cdddr $cdr $cdr $cdr]
[caaaar $car $car $car $car]
[cdaaar $cdr $car $car $car]
[cadaar $car $cdr $car $car]
[cddaar $cdr $cdr $car $car]
[caadar $car $car $cdr $car]
[cdadar $cdr $car $cdr $car]
[caddar $car $cdr $cdr $car]
[cdddar $cdr $cdr $cdr $car]
[caaadr $car $car $car $cdr]
[cdaadr $cdr $car $car $cdr]
[cadadr $car $cdr $car $cdr]
[cddadr $cdr $cdr $car $cdr]
[caaddr $car $car $cdr $cdr]
[cdaddr $cdr $car $cdr $cdr]
[cadddr $car $cdr $cdr $cdr]
[cddddr $cdr $cdr $cdr $cdr]))