picrin/contrib/20.r7rs/scheme/base.scm

564 lines
13 KiB
Scheme
Raw Normal View History

2014-08-03 02:47:25 -04:00
(define-library (scheme base)
2014-08-05 12:16:37 -04:00
(import (picrin base)
2014-09-08 07:20:08 -04:00
(picrin macro)
2014-09-21 02:33:52 -04:00
(picrin syntax-rules)
(picrin string)
(scheme file))
2014-09-08 07:20:08 -04:00
;; 4.1.2. Literal expressions
(export quote)
;; 4.1.4. Procedures
(export lambda)
;; 4.1.5. Conditionals
(export if)
;; 4.1.6. Assignments
(export set!)
;; 4.1.7. Inclusion
(define-syntax include
(letrec ((read-file
(lambda (filename)
(call-with-port (open-input-file filename)
(lambda (port)
(let loop ((expr (read port)) (exprs '()))
(if (eof-object? expr)
(reverse exprs)
(loop (read port) (cons expr exprs)))))))))
(er-macro-transformer
(lambda (form rename compare)
(let ((filenames (cdr form)))
(let ((exprs (apply append (map read-file filenames))))
`(,(rename 'begin) ,@exprs)))))))
2014-09-08 07:20:08 -04:00
(export include)
;; 4.2.1. Conditionals
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
(export cond
case
2014-09-08 11:59:12 -04:00
else
=>
2014-09-08 07:20:08 -04:00
and
or
when
unless)
;; 4.2.2. Binding constructs
(export let
let*
letrec
letrec*
let-values
let*-values)
;; 4.2.3. Sequencing
(export begin)
;; 4.2.4. Iteration
(export do)
;; 4.2.6. Dynamic bindings
2014-09-08 07:20:08 -04:00
(export make-parameter
parameterize)
;; 4.2.7. Exception handling
2015-07-08 14:58:08 -04:00
(define-syntax (guard-aux reraise . clauses)
(letrec
((else?
(lambda (clause)
(and (list? clause) (equal? #'else (car clause)))))
(=>?
(lambda (clause)
(and (list? clause) (= (length clause) 3) (equal? #'=> (list-ref clause 1))))))
(if (null? clauses)
reraise
(let ((clause (car clauses)))
(cond
((else? clause)
#`(begin #,@(cdr clause)))
((=>? clause)
#`(let ((tmp #,(list-ref clause 0)))
(if tmp
(#,(list-ref clause 2) tmp)
(guard-aux #,reraise #,@(cdr clauses)))))
(else
#`(if #,(car clause)
(begin #,@(cdr clause))
(guard-aux #,reraise #,@(cdr clauses)))))))))
(define-syntax (guard formal . body)
(let ((var (car formal))
(clauses (cdr formal)))
#`((call/cc
(lambda (guard-k)
(with-exception-handler
(lambda (condition)
((call/cc
(lambda (handler-k)
(guard-k
(lambda ()
(let ((#,var condition))
(guard-aux
(handler-k
(lambda ()
(raise-continuable condition)))
#,@clauses))))))))
(lambda ()
(call-with-values
(lambda () #,@body)
(lambda args
(guard-k
(lambda ()
(apply values args))))))))))))
2014-08-03 02:47:25 -04:00
(export guard)
2014-09-08 07:20:08 -04:00
;; 4.2.8. Quasiquotation
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
(export quasiquote
unquote
unquote-splicing)
2014-09-08 07:20:08 -04:00
;; 4.3.1. Binding constructs for syntactic keywords
(export let-syntax
letrec-syntax)
;; 4.3.2 Pattern language
2014-09-08 11:59:12 -04:00
(export syntax-rules
_
...)
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
;; 4.3.3. Signaling errors in macro transformers
2014-08-31 20:53:19 -04:00
2014-09-08 07:20:08 -04:00
(export syntax-error)
;; 5.3. Variable definitions
(export define)
;; 5.3.3. Multiple-value definitions
(export define-values)
;; 5.4. Syntax definitions
(export define-syntax)
;; 5.5 Recored-type definitions
(define ((boot-make-record-type <meta-type>) name)
(let ((rectype (make-record <meta-type>)))
(record-set! rectype 'name name)
rectype))
(define <record-type>
(let ((<record-type> ((boot-make-record-type #t) 'record-type)))
(record-set! <record-type> '@@type <record-type>)
<record-type>))
(define make-record-type (boot-make-record-type <record-type>))
(define-syntax (define-record-constructor type name . fields)
(let ((record #'record))
#`(define (#,name . #,fields)
(let ((#,record (make-record #,type)))
#,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
#,record))))
(define-syntax (define-record-predicate type name)
#`(define (#,name obj)
(and (record? obj)
(eq? (record-type obj) #,type))))
(define-syntax (define-record-accessor pred field accessor)
#`(define (#,accessor record)
(if (#,pred record)
(record-ref record '#,field)
(error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(define-syntax (define-record-modifier pred field modifier)
#`(define (#,modifier record val)
(if (#,pred record)
(record-set! record '#,field val)
(error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
(define-syntax (define-record-field pred field accessor . modifier-opt)
(if (null? modifier-opt)
#`(define-record-accessor #,pred #,field #,accessor)
#`(begin
(define-record-accessor #,pred #,field #,accessor)
(define-record-modifier #,pred #,field #,(car modifier-opt)))))
(define-syntax (define-record-type name ctor pred . fields)
#`(begin
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
2014-09-08 07:20:08 -04:00
(export define-record-type)
;; 6.1. Equivalence predicates
2014-09-08 04:08:38 -04:00
(export eq?
eqv?
equal?)
2014-09-08 07:20:08 -04:00
;; 6.2. Numbers
2014-09-08 04:08:38 -04:00
2014-09-08 07:20:08 -04:00
(define (exact-integer? x)
(and (exact? x)
(integer? x)))
(define (zero? x)
(= x 0))
(define (positive? x)
(> x 0))
(define (negative? x)
(< x 0))
2014-09-08 07:37:44 -04:00
(define (even? x)
2014-09-08 12:31:25 -04:00
(= x (* (exact (floor (/ x 2))) 2)))
2014-09-08 07:37:44 -04:00
(define (odd? x)
(not (even? x)))
2014-09-08 07:20:08 -04:00
(define (min . args)
2014-09-08 13:29:24 -04:00
(define (min a b)
(if (< a b) a b))
2014-09-18 10:26:07 -04:00
(let loop ((args args) (acc +inf.0) (exactp #t))
2014-09-08 07:20:08 -04:00
(if (null? args)
2014-09-18 10:26:07 -04:00
(if exactp acc (inexact acc))
(loop (cdr args) (min (car args) acc) (and (exact? (car args)) exactp)))))
2014-09-08 07:20:08 -04:00
(define (max . args)
2014-09-08 13:29:24 -04:00
(define (max a b)
(if (> a b) a b))
2014-09-18 10:26:07 -04:00
(let loop ((args args) (acc -inf.0) (exactp #t))
2014-09-08 07:20:08 -04:00
(if (null? args)
2014-09-18 10:26:07 -04:00
(if exactp acc (inexact acc))
(loop (cdr args) (max (car args) acc) (and (exact? (car args)) exactp)))))
2014-09-08 07:20:08 -04:00
2014-09-08 07:37:44 -04:00
(define (floor-quotient i j)
(call-with-values (lambda () (floor/ i j))
(lambda (q r)
q)))
(define (floor-remainder i j)
(call-with-values (lambda () (floor/ i j))
(lambda (q r)
r)))
(define (truncate-quotient i j)
(call-with-values (lambda () (truncate/ i j))
(lambda (q r)
q)))
(define (truncate-remainder i j)
(call-with-values (lambda () (truncate/ i j))
(lambda (q r)
r)))
(define (gcd . args)
(define (gcd i j)
(cond
((> i j) (gcd j i))
((< i 0) (gcd (- i) j))
((> i 0) (gcd (truncate-remainder j i) i))
(else j)))
(let loop ((args args) (acc 0))
(if (null? args)
acc
(loop (cdr args)
(gcd acc (car args))))))
(define (lcm . args)
(define (lcm i j)
2014-09-08 13:24:19 -04:00
(/ (abs (* i j)) (gcd i j)))
(let loop ((args args) (acc 1))
(if (null? args)
acc
(loop (cdr args)
(lcm acc (car args))))))
2014-09-08 07:37:44 -04:00
2014-09-08 07:20:08 -04:00
(define (square x)
(* x x))
2014-09-08 04:08:38 -04:00
2014-09-08 07:37:44 -04:00
(define (exact-integer-sqrt k)
(let ((s (exact (floor (sqrt k)))))
2014-09-08 07:37:44 -04:00
(values s (- k (square s)))))
2014-09-08 04:08:38 -04:00
(export number?
complex?
real?
rational?
integer?
exact?
inexact?
exact-integer?
2014-09-08 07:37:44 -04:00
exact
inexact
2014-09-08 04:08:38 -04:00
=
<
>
<=
>=
zero?
positive?
negative?
2014-09-08 07:37:44 -04:00
odd?
even?
2014-09-08 04:08:38 -04:00
min
max
+
-
*
/
abs
2014-09-08 07:37:44 -04:00
floor-quotient
floor-remainder
2014-09-08 04:08:38 -04:00
floor/
2014-09-08 07:37:44 -04:00
truncate-quotient
truncate-remainder
2014-09-08 04:08:38 -04:00
truncate/
2014-09-08 07:37:44 -04:00
(rename truncate-quotient quotient)
(rename truncate-remainder remainder)
(rename floor-remainder modulo)
gcd
lcm
2014-09-08 04:08:38 -04:00
floor
ceiling
truncate
round
2014-09-08 07:37:44 -04:00
exact-integer-sqrt
2014-09-08 04:08:38 -04:00
square
expt
number->string
2014-09-08 07:20:08 -04:00
string->number)
2014-09-08 04:08:38 -04:00
2014-09-08 07:20:08 -04:00
;; 6.3. Booleans
2014-09-08 04:08:38 -04:00
2014-09-08 07:20:08 -04:00
(export boolean?
boolean=?
not)
2014-09-08 04:08:38 -04:00
;; 6.4 Pairs and lists
(export pair?
cons
car
cdr
set-car!
set-cdr!
null?
caar
cadr
cdar
cddr
list?
make-list
list
length
append
reverse
list-tail
list-ref
list-set!
list-copy
memq
memv
member
assq
assv
assoc)
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
;; 6.5. Symbols
2014-08-05 13:14:43 -04:00
(export symbol?
symbol=?
symbol->string
string->symbol)
2014-09-08 07:20:08 -04:00
;; 6.6. Characters
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
(export char?
char->integer
integer->char
char=?
2014-08-03 02:47:25 -04:00
char<?
char>?
char<=?
char>=?)
2014-09-08 07:20:08 -04:00
;; 6.7. Strings
(export string?
2014-09-08 12:28:08 -04:00
string
make-string
2014-09-08 07:20:08 -04:00
string-length
string-ref
2014-09-08 12:28:08 -04:00
string-set!
2014-09-08 07:20:08 -04:00
string-copy
2014-09-08 12:28:08 -04:00
string-copy!
2014-09-08 07:20:08 -04:00
string-append
2014-09-12 08:21:29 -04:00
(rename string-copy substring)
2014-09-08 12:28:08 -04:00
string-fill!
2014-09-12 08:21:29 -04:00
string->list
list->string
2014-09-08 07:20:08 -04:00
string=?
string<?
string>?
string<=?
2014-09-12 08:21:29 -04:00
string>=?)
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
;; 6.8. Vectors
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
(export vector?
2014-09-12 08:21:29 -04:00
vector
2014-09-08 07:20:08 -04:00
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
list->vector
2014-09-12 08:21:29 -04:00
vector->list
string->vector
vector->string)
;; 6.9. Bytevectors
2014-08-03 02:47:25 -04:00
2014-09-08 12:28:08 -04:00
(define (utf8->string v . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(bytevector-length v))))
(list->string (map integer->char (bytevector->list v start end)))))
2014-08-03 02:47:25 -04:00
2014-09-08 07:37:44 -04:00
(define (string->utf8 s . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length s))))
(list->bytevector (map char->integer (string->list s start end)))))
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
(export bytevector?
bytevector
2014-09-08 07:20:08 -04:00
make-bytevector
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
bytevector-copy
2014-09-08 07:20:08 -04:00
bytevector-copy!
bytevector-append
bytevector->list
list->bytevector
utf8->string
string->utf8)
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
;; 6.10. Control features
2014-08-03 02:47:25 -04:00
2014-09-08 07:20:08 -04:00
(export procedure?
apply
map
for-each
string-map
string-for-each
vector-map
vector-for-each
2014-09-08 07:20:08 -04:00
call-with-current-continuation
call/cc
dynamic-wind
values
call-with-values)
;; 6.11. Exceptions
(define (read-error? obj)
(and (error-object? obj)
(eq? (error-object-type obj) 'read)))
(define (file-error? obj)
(and (error-object? obj)
(eq? (error-object-type obj) 'file)))
2014-09-08 07:20:08 -04:00
(export with-exception-handler
raise
raise-continuable
error
error-object?
error-object-message
error-object-irritants
read-error?
file-error?)
2014-08-03 02:47:25 -04:00
;; 6.13. Input and output
2014-09-08 07:20:08 -04:00
(export current-input-port
current-output-port
current-error-port
call-with-port
port?
input-port?
output-port?
textual-port?
binary-port?
(rename port-open? input-port-open?)
(rename port-open? output-port-open?)
2014-09-08 07:20:08 -04:00
close-port
(rename close-port close-input-port)
(rename close-port close-output-port)
open-input-string
open-output-string
get-output-string
open-input-bytevector
open-output-bytevector
get-output-bytevector
eof-object?
eof-object
read-char
peek-char
char-ready?
read-line
read-string
read-u8
peek-u8
u8-ready?
read-bytevector
read-bytevector!
newline
write-char
write-string
write-u8
write-bytevector
flush-output-port)
(export features))