[bpt/guile.git] / module / rnrs / base.scm

;;; base.scm --- The R6RS base library

;;      Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This library 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
;; Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
\f

(library (rnrs base (6))
  (export boolean? symbol? char? vector? null? pair? number? string? procedure?
	 
	  define define-syntax syntax-rules lambda let let* let-values 
	  let*-values letrec letrec* begin 

	  quote lambda if set! cond case 
	 
	  or and not
	 
	  eqv? equal? eq?
	 
	  + - * / max min abs numerator denominator gcd lcm floor ceiling
	  truncate round rationalize real-part imag-part make-rectangular angle
	  div mod div-and-mod div0 mod0 div0-and-mod0
	  
	  expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan 
	  make-polar magnitude angle
	 
	  complex? real? rational? integer? exact? inexact? real-valued?
	  rational-valued? integer-valued? zero? positive? negative? odd? even?
	  nan? finite? infinite?

	  exact inexact = < > <= >= 

	  number->string string->number

          boolean=?

	  cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr 
	  cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr 
	  cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr

	  list? list length append reverse list-tail list-ref map for-each

	  symbol->string string->symbol symbol=?

	  char->integer integer->char char=? char<? char>? char<=? char>=?

	  make-string string string-length string-ref string=? string<? string>?
	  string<=? string>=? substring string-append string->list list->string
	  string-for-each string-copy

	  vector? make-vector vector vector-length vector-ref vector-set! 
	  vector->list list->vector vector-fill! vector-map vector-for-each

	  error assertion-violation assert

	  call-with-current-continuation call/cc call-with-values dynamic-wind
	  values apply

	  quasiquote unquote unquote-splicing

	  let-syntax letrec-syntax

	  syntax-rules identifier-syntax)
  (import (rename (except (guile) error raise map string-for-each)
                  (log log-internal)
                  (euclidean-quotient div)
                  (euclidean-remainder mod)
                  (euclidean/ div-and-mod)
                  (centered-quotient div0)
                  (centered-remainder mod0)
                  (centered/ div0-and-mod0)
                  (inf? infinite?)
                  (exact->inexact inexact)
                  (inexact->exact exact))
          (srfi srfi-11))

 (define string-for-each
   (case-lambda
     ((proc string)
      (let ((end (string-length string)))
        (let loop ((i 0))
          (unless (= i end)
            (proc (string-ref string i))
            (loop (+ i 1))))))
     ((proc string1 string2)
      (let ((end1 (string-length string1))
            (end2 (string-length string2)))
        (unless (= end1 end2)
          (assertion-violation 'string-for-each
                               "string arguments must all have the same length"
                               string1 string2))
        (let loop ((i 0))
          (unless (= i end1)
            (proc (string-ref string1 i)
                  (string-ref string2 i))
            (loop (+ i 1))))))
     ((proc string . strings)
      (let ((end (string-length string))
            (ends (map string-length strings)))
        (for-each (lambda (x)
                    (unless (= end x)
                      (apply assertion-violation
                             'string-for-each
                             "string arguments must all have the same length"
                             string strings)))
                  ends)
        (let loop ((i 0))
          (unless (= i end)
            (apply proc
                   (string-ref string i)
                   (map (lambda (s) (string-ref s i)) strings))
            (loop (+ i 1))))))))

 (define map
   (case-lambda
     ((f l)
      (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
        (if (pair? hare)
            (if move?
                (if (eq? tortoise hare)
                    (scm-error 'wrong-type-arg "map" "Circular list: ~S"
                               (list l) #f)
                    (map1 (cdr hare) (cdr tortoise) #f
                          (cons (f (car hare)) out)))
                (map1 (cdr hare) tortoise #t
                      (cons (f (car hare)) out)))
            (if (null? hare)
                (reverse out)
                (scm-error 'wrong-type-arg "map" "Not a list: ~S"
                           (list l) #f)))))
    
     ((f l1 l2)
      (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
        (cond
         ((pair? h1)
          (cond
           ((not (pair? h2))
            (scm-error 'wrong-type-arg "map"
                       (if (list? h2)
                           "List of wrong length: ~S"
                           "Not a list: ~S")
                       (list l2) #f))
           ((not move?)
            (map2 (cdr h1) (cdr h2) t1 t2 #t
                  (cons (f (car h1) (car h2)) out)))
           ((eq? t1 h1)
            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
                       (list l1) #f))
           ((eq? t2 h2)
            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
                       (list l2) #f))
           (else
            (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
                  (cons (f (car h1) (car h2)) out)))))

         ((and (null? h1) (null? h2))
          (reverse out))
        
         ((null? h1)
          (scm-error 'wrong-type-arg "map"
                     (if (list? h2)
                         "List of wrong length: ~S"
                         "Not a list: ~S")
                     (list l2) #f))
         (else
          (scm-error 'wrong-type-arg "map"
                     "Not a list: ~S"
                     (list l1) #f)))))

     ((f l1 . rest)
      (let ((len (length l1)))
        (let mapn ((rest rest))
          (or (null? rest)
              (if (= (length (car rest)) len)
                  (mapn (cdr rest))
                  (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
                             (list (car rest)) #f)))))
      (let mapn ((l1 l1) (rest rest) (out '()))
        (if (null? l1)
            (reverse out)
            (mapn (cdr l1) (map cdr rest)
                  (cons (apply f (car l1) (map car rest)) out)))))))

 (define log
   (case-lambda
     ((n)
      (log-internal n))
     ((n base)
      (/ (log n)
         (log base)))))

 (define (boolean=? . bools)
   (define (boolean=?-internal lst last)
     (or (null? lst)
         (let ((bool (car lst))) 
           (and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
   (or (null? bools)
       (let ((bool (car bools)))
         (and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))

 (define (symbol=? . syms)
   (define (symbol=?-internal lst last)
     (or (null? lst)
         (let ((sym (car lst))) 
           (and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
   (or (null? syms)
       (let ((sym (car syms)))
         (and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))

 (define (real-valued? x)
   (and (complex? x)
        (zero? (imag-part x))))

 (define (rational-valued? x)
   (and (real-valued? x)
        (rational? (real-part x))))

 (define (integer-valued? x)
   (and (rational-valued? x)
        (= x (floor (real-part x)))))

 (define (vector-for-each proc . vecs)
   (apply for-each (cons proc (map vector->list vecs))))
 (define (vector-map proc . vecs)
   (list->vector (apply map (cons proc (map vector->list vecs)))))

 (define-syntax define-proxy
   (syntax-rules (@)
     ;; Define BINDING to point to (@ MODULE ORIGINAL).  This hack is to
     ;; make sure MODULE is loaded lazily, at run-time, when BINDING is
     ;; encountered, rather than being loaded while compiling and
     ;; loading (rnrs base).
     ;; This avoids circular dependencies among modules and makes
     ;; (rnrs base) more lightweight.
     ((_ binding (@ module original))
      (define-syntax binding
        (identifier-syntax
         (module-ref (resolve-interface 'module) 'original))))))

 (define-proxy raise
   (@ (rnrs exceptions) raise))

 (define-proxy condition
   (@ (rnrs conditions) condition))
 (define-proxy make-error
   (@ (rnrs conditions) make-error))
 (define-proxy make-assertion-violation
   (@ (rnrs conditions) make-assertion-violation))
 (define-proxy make-who-condition
   (@ (rnrs conditions) make-who-condition))
 (define-proxy make-message-condition
   (@ (rnrs conditions) make-message-condition))
 (define-proxy make-irritants-condition
   (@ (rnrs conditions) make-irritants-condition))

 (define (error who message . irritants)
   (raise (apply condition
                 (append (list (make-error))
                         (if who (list (make-who-condition who)) '())
                         (list (make-message-condition message)
                               (make-irritants-condition irritants))))))
 
 (define (assertion-violation who message . irritants)
   (raise (apply condition
                 (append (list (make-assertion-violation))
                         (if who (list (make-who-condition who)) '())
                         (list (make-message-condition message)
                               (make-irritants-condition irritants))))))

 (define-syntax assert
   (syntax-rules ()
     ((_ expression)
      (or expression
          (raise (condition
                  (make-assertion-violation)
                  (make-message-condition
                   (format #f "assertion failed: ~s" 'expression))))))))

)
Commit	Line	Data
bf745816 JG	1	;;; base.scm --- The R6RS base library
bf745816 JG	2
7112615f	3	;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
bf745816 JG	4	;;
	5	;; This library is free software; you can redistribute it and/or
	6	;; modify it under the terms of the GNU Lesser General Public
	7	;; License as published by the Free Software Foundation; either
	8	;; version 3 of the License, or (at your option) any later version.
	9	;;
	10	;; This library is distributed in the hope that it will be useful,
	11	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;; Lesser General Public License for more details.
	14	;;
	15	;; You should have received a copy of the GNU Lesser General Public
	16	;; License along with this library; if not, write to the Free Software
	17	;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18	\f
	19
	20	(library (rnrs base (6))
	21	(export boolean? symbol? char? vector? null? pair? number? string? procedure?
	22
	23	define define-syntax syntax-rules lambda let let* let-values
935c7aca	24	let-values letrec letrec begin
bf745816 JG	25
	26	quote lambda if set! cond case
	27
	28	or and not
	29
	30	eqv? equal? eq?
	31
	32	+ - * / max min abs numerator denominator gcd lcm floor ceiling
	33	truncate round rationalize real-part imag-part make-rectangular angle
	34	div mod div-and-mod div0 mod0 div0-and-mod0
	35
	36	expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan
	37	make-polar magnitude angle
	38
	39	complex? real? rational? integer? exact? inexact? real-valued?
b98d5a5a	40	rational-valued? integer-valued? zero? positive? negative? odd? even?
bf745816 JG	41	nan? finite? infinite?
	42
	43	exact inexact = < > <= >=
	44
	45	number->string string->number
	46
b98d5a5a JG	47	boolean=?
b98d5a5a JG	48
bf745816 JG	49	cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr
	50	cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr
	51	cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr
	52
	53	list? list length append reverse list-tail list-ref map for-each
	54
b3961e7a	55	symbol->string string->symbol symbol=?
bf745816 JG	56
	57	char->integer integer->char char=? char<? char>? char<=? char>=?
	58
	59	make-string string string-length string-ref string=? string<? string>?
	60	string<=? string>=? substring string-append string->list list->string
	61	string-for-each string-copy
	62
	63	vector? make-vector vector vector-length vector-ref vector-set!
	64	vector->list list->vector vector-fill! vector-map vector-for-each
	65
	66	error assertion-violation assert
	67
	68	call-with-current-continuation call/cc call-with-values dynamic-wind
	69	values apply
	70
	71	quasiquote unquote unquote-splicing
	72
	73	let-syntax letrec-syntax
	74
	75	syntax-rules identifier-syntax)
06906f37	76	(import (rename (except (guile) error raise map string-for-each)
cf9d4a82	77	(log log-internal)
ff62c168 MW	78	(euclidean-quotient div)
	79	(euclidean-remainder mod)
	80	(euclidean/ div-and-mod)
	81	(centered-quotient div0)
	82	(centered-remainder mod0)
	83	(centered/ div0-and-mod0)
7112615f	84	(inf? infinite?)
b98d5a5a JG	85	(exact->inexact inexact)
	86	(inexact->exact exact))
	87	(srfi srfi-11))
	88
06906f37 IP	89	(define string-for-each
	90	(case-lambda
	91	((proc string)
	92	(let ((end (string-length string)))
	93	(let loop ((i 0))
	94	(unless (= i end)
	95	(proc (string-ref string i))
	96	(loop (+ i 1))))))
	97	((proc string1 string2)
	98	(let ((end1 (string-length string1))
	99	(end2 (string-length string2)))
	100	(unless (= end1 end2)
	101	(assertion-violation 'string-for-each
	102	"string arguments must all have the same length"
	103	string1 string2))
	104	(let loop ((i 0))
	105	(unless (= i end1)
	106	(proc (string-ref string1 i)
	107	(string-ref string2 i))
	108	(loop (+ i 1))))))
	109	((proc string . strings)
	110	(let ((end (string-length string))
	111	(ends (map string-length strings)))
	112	(for-each (lambda (x)
	113	(unless (= end x)
	114	(apply assertion-violation
	115	'string-for-each
	116	"string arguments must all have the same length"
	117	string strings)))
	118	ends)
	119	(let loop ((i 0))
	120	(unless (= i end)
	121	(apply proc
	122	(string-ref string i)
	123	(map (lambda (s) (string-ref s i)) strings))
	124	(loop (+ i 1))))))))
	125
b8f19196 AW	126	(define map
	127	(case-lambda
	128	((f l)
	129	(let map1 ((hare l) (tortoise l) (move? #f) (out '()))
	130	(if (pair? hare)
	131	(if move?
	132	(if (eq? tortoise hare)
	133	(scm-error 'wrong-type-arg "map" "Circular list: ~S"
	134	(list l) #f)
	135	(map1 (cdr hare) (cdr tortoise) #f
	136	(cons (f (car hare)) out)))
	137	(map1 (cdr hare) tortoise #t
	138	(cons (f (car hare)) out)))
	139	(if (null? hare)
	140	(reverse out)
	141	(scm-error 'wrong-type-arg "map" "Not a list: ~S"
	142	(list l) #f)))))
	143
	144	((f l1 l2)
	145	(let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
	146	(cond
	147	((pair? h1)
	148	(cond
	149	((not (pair? h2))
	150	(scm-error 'wrong-type-arg "map"
	151	(if (list? h2)
	152	"List of wrong length: ~S"
	153	"Not a list: ~S")
	154	(list l2) #f))
	155	((not move?)
	156	(map2 (cdr h1) (cdr h2) t1 t2 #t
	157	(cons (f (car h1) (car h2)) out)))
	158	((eq? t1 h1)
	159	(scm-error 'wrong-type-arg "map" "Circular list: ~S"
	160	(list l1) #f))
	161	((eq? t2 h2)
	162	(scm-error 'wrong-type-arg "map" "Circular list: ~S"
	163	(list l2) #f))
	164	(else
	165	(map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
	166	(cons (f (car h1) (car h2)) out)))))
	167
	168	((and (null? h1) (null? h2))
	169	(reverse out))
	170
	171	((null? h1)
	172	(scm-error 'wrong-type-arg "map"
	173	(if (list? h2)
	174	"List of wrong length: ~S"
	175	"Not a list: ~S")
	176	(list l2) #f))
	177	(else
	178	(scm-error 'wrong-type-arg "map"
	179	"Not a list: ~S"
	180	(list l1) #f)))))
	181
	182	((f l1 . rest)
	183	(let ((len (length l1)))
	184	(let mapn ((rest rest))
	185	(or (null? rest)
	186	(if (= (length (car rest)) len)
	187	(mapn (cdr rest))
	188	(scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
	189	(list (car rest)) #f)))))
190	(let mapn ((l1 l1) (rest rest) (out '()))
191	(if (null? l1)
192	(reverse out)
193	(mapn (cdr l1) (map cdr rest)
194	(cons (apply f (car l1) (map car rest)) out)))))))
195
cf9d4a82 IP	196	(define log
	197	(case-lambda
	198	((n)
	199	(log-internal n))
	200	((n base)
	201	(/ (log n)
	202	(log base)))))
	203
b98d5a5a JG	204	(define (boolean=? . bools)
	205	(define (boolean=?-internal lst last)
	206	(or (null? lst)
	207	(let ((bool (car lst)))
	208	(and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
	209	(or (null? bools)
	210	(let ((bool (car bools)))
	211	(and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))
	212
	213	(define (symbol=? . syms)
	214	(define (symbol=?-internal lst last)
	215	(or (null? lst)
	216	(let ((sym (car lst)))
	217	(and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
	218	(or (null? syms)
	219	(let ((sym (car syms)))
	220	(and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
	221
8f2339c4 MW	222	(define (real-valued? x)
	223	(and (complex? x)
	224	(zero? (imag-part x))))
	225
	226	(define (rational-valued? x)
	227	(and (real-valued? x)
	228	(rational? (real-part x))))
	229
	230	(define (integer-valued? x)
	231	(and (rational-valued? x)
	232	(= x (floor (real-part x)))))
b01818d7	233
b24b7deb JG	234	(define (vector-for-each proc . vecs)
	235	(apply for-each (cons proc (map vector->list vecs))))
	236	(define (vector-map proc . vecs)
	237	(list->vector (apply map (cons proc (map vector->list vecs)))))
	238
630b6588 LC	239	(define-syntax define-proxy
	240	(syntax-rules (@)
	241	;; Define BINDING to point to (@ MODULE ORIGINAL). This hack is to
	242	;; make sure MODULE is loaded lazily, at run-time, when BINDING is
	243	;; encountered, rather than being loaded while compiling and
	244	;; loading (rnrs base).
	245	;; This avoids circular dependencies among modules and makes
	246	;; (rnrs base) more lightweight.
	247	((_ binding (@ module original))
	248	(define-syntax binding
	249	(identifier-syntax
	250	(module-ref (resolve-interface 'module) 'original))))))
	251
	252	(define-proxy raise
	253	(@ (rnrs exceptions) raise))
	254
	255	(define-proxy condition
23988e8c	256	(@ (rnrs conditions) condition))
630b6588	257	(define-proxy make-error
c0f6c163	258	(@ (rnrs conditions) make-error))
630b6588	259	(define-proxy make-assertion-violation
23988e8c	260	(@ (rnrs conditions) make-assertion-violation))
630b6588	261	(define-proxy make-who-condition
23988e8c	262	(@ (rnrs conditions) make-who-condition))
630b6588	263	(define-proxy make-message-condition
23988e8c	264	(@ (rnrs conditions) make-message-condition))
630b6588	265	(define-proxy make-irritants-condition
23988e8c	266	(@ (rnrs conditions) make-irritants-condition))
c0f6c163 AR	267
	268	(define (error who message . irritants)
	269	(raise (apply condition
	270	(append (list (make-error))
	271	(if who (list (make-who-condition who)) '())
	272	(list (make-message-condition message)
	273	(make-irritants-condition irritants))))))
23988e8c AR	274
23988e8c AR	275	(define (assertion-violation who message . irritants)
c0f6c163 AR	276	(raise (apply condition
	277	(append (list (make-assertion-violation))
	278	(if who (list (make-who-condition who)) '())
	279	(list (make-message-condition message)
	280	(make-irritants-condition irritants))))))
	281
	282	(define-syntax assert
	283	(syntax-rules ()
	284	((_ expression)
15993bce	285	(or expression
c0f6c163 AR	286	(raise (condition
	287	(make-assertion-violation)
	288	(make-message-condition
	289	(format #f "assertion failed: ~s" 'expression))))))))
23988e8c	290
b01818d7	291	)