20071025 16:27:34 04:00



;;; Ikarus Scheme  A compiler for R6RS Scheme.

20080129 00:34:34 05:00



;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum

20071025 16:27:34 04:00



;;;




;;; 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/>.





20061207 02:48:31 05:00




20070211 21:42:01 05:00




20070505 05:06:32 04:00



(library (ikarus pairs)

20070506 18:43:04 04:00



(export




cons weakcons setcar! setcdr! 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)

20070505 02:28:30 04:00



(import

20070506 18:43:04 04:00



(except (ikarus) cons weakcons setcar! setcdr! 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))

20070430 00:35:28 04:00




20070505 05:07:49 04:00



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

20070505 05:15:53 04:00




20070505 06:18:29 04:00



(define weakcons




(lambda (a d)




(foreigncall "ikrt_weak_cons" a d)))





20070505 05:15:53 04:00



(define setcar!




(lambda (x y)




(unless (pair? x)

20071215 08:22:49 05:00



(die 'setcar! "not a pair" x))

20070505 05:15:53 04:00



($setcar! x y)))








(define setcdr!




(lambda (x y)




(unless (pair? x)

20071215 08:22:49 05:00



(die 'setcdr! "not a pair" x))

20070505 05:15:53 04:00



($setcdr! x y)))





20070508 19:19:50 04:00



(definesyntax cxr




(syntaxrules ()




[(_ 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))]))








(definesyntax definecxr*




(syntaxrules ()




[(_ [name* ops** ...] ...)




(begin




(define name*

20070508 19:38:05 04:00



(lambda (x)

20071218 11:32:13 05:00



((cxr (die 'name*




"argument does not have required pair structure" x)




ops** ...)

20070508 19:38:05 04:00



x)))

20070508 19:19:50 04:00



...)]))








(definecxr*




[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]))

20080628 05:25:44 04:00











(library (ikarus system pairs)




(export $car $cdr)




(import (ikarus))




(define $car car)




(define $cdr cdr))




