base.scm 12 KB

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