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

811 lines
21 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)
2015-07-19 12:18:57 -04:00
(only (picrin math)
floor/
truncate/
floor
ceiling
truncate
round
sqrt)
2014-09-08 07:20:08 -04:00
(picrin macro)
(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
2015-07-08 15:13:35 -04:00
(let ((clause (car clauses))
(rest (cdr clauses)))
2015-07-08 14:58:08 -04:00
(cond
((else? clause)
#`(begin #,@(cdr clause)))
((=>? clause)
#`(let ((tmp #,(list-ref clause 0)))
(if tmp
(#,(list-ref clause 2) tmp)
2015-07-08 15:13:35 -04:00
(guard-aux #,reraise #,@rest))))
((= (length clause) 1)
#`(or #,(car clause) (guard-aux #,reraise #,@rest)))
2015-07-08 14:58:08 -04:00
(else
#`(if #,(car clause)
(begin #,@(cdr clause))
2015-07-08 15:13:35 -04:00
(guard-aux #,reraise #,@rest))))))))
2015-07-08 14:58:08 -04:00
(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
2015-07-08 15:02:55 -04:00
(define (succ n)
(+ n 1))
(define (pred n)
(if (= n 0)
0
(- n 1)))
(define (every? args)
(if (null? args)
#t
(if (car args)
(every? (cdr args))
#f)))
(define (filter f list)
(if (null? list)
'()
(if (f (car list))
(cons (car list)
(filter f (cdr list)))
(filter f (cdr list)))))
(define (take-tail n list)
(let drop ((n (- (length list) n)) (list list))
(if (= n 0)
list
(drop (- n 1) (cdr list)))))
(define (drop-tail n list)
(let take ((n (- (length list) n)) (list list))
(if (= n 0)
'()
(cons (car list) (take (- n 1) (cdr list))))))
(define (map-keys f assoc)
(map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
(define (map-values f assoc)
(map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
;; TODO
;; - placeholder
;; - vector
;; - (... template) pattern
;; p ::= constant
;; | var
;; | (p ... . p) (in input pattern, tail p should be a proper list)
;; | (p . p)
(define (compile ellipsis literals rules)
(define (constant? obj)
(and (not (pair? obj))
(not (variable? obj))))
(define (literal? obj)
(and (variable? obj)
(memq obj literals)))
(define (many? pat)
(and (pair? pat)
(pair? (cdr pat))
(variable? (cadr pat))
(variable=? (cadr pat) ellipsis)))
(define (pattern-validator pat) ; pattern -> validator
(letrec
((pattern-validator
(lambda (pat form)
(cond
((constant? pat)
#`(equal? '#,pat #,form))
((literal? pat)
#`(and (variable? #,form) (variable=? #'#,pat #,form)))
((variable? pat)
#t)
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
#`(and (list? #,form)
(>= (length #,form) #,(length (cddr pat)))
(every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head))
#,(pattern-validator (cddr pat) tail))))
((pair? pat)
#`(and (pair? #,form)
#,(pattern-validator (car pat) #`(car #,form))
#,(pattern-validator (cdr pat) #`(cdr #,form))))
(else
#f)))))
(pattern-validator pat 'it)))
(define (pattern-variables pat) ; pattern -> (freevar)
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`(,pat))
((many? pat)
(append (pattern-variables (car pat))
(pattern-variables (cddr pat))))
((pair? pat)
(append (pattern-variables (car pat))
(pattern-variables (cdr pat))))))
(define (pattern-levels pat) ; pattern -> ((var * int))
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`((,pat . 0)))
((many? pat)
(append (map-values succ (pattern-levels (car pat)))
(pattern-levels (cddr pat))))
((pair? pat)
(append (pattern-levels (car pat))
(pattern-levels (cdr pat))))))
(define (pattern-selectors pat) ; pattern -> ((var * selector))
(letrec
((pattern-selectors
(lambda (pat form)
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`((,pat . ,form)))
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
(let ((envs (pattern-selectors (car pat) 'it)))
(append
(map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs)
(pattern-selectors (cddr pat) tail)))))
((pair? pat)
(append (pattern-selectors (car pat) #`(car #,form))
(pattern-selectors (cdr pat) #`(cdr #,form))))))))
(pattern-selectors pat 'it)))
(define (template-representation pat levels selectors)
(cond
((constant? pat)
pat)
((variable? pat)
(let ((it (assq pat levels)))
(if it
(if (= 0 (cdr it))
(cdr (assq pat selectors))
(error "unmatched pattern variable level" pat))
#`(#,'rename '#,pat))))
((many? pat)
(letrec*
((inner-pat
(car pat))
(inner-levels
(map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels))
(inner-freevars
(filter (lambda (v) (assq v levels)) (pattern-variables inner-pat)))
(inner-vars
;; select only vars declared with ellipsis
(filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars))
(inner-tmps
(map (lambda (v) #'it) inner-vars))
(inner-selectors
;; first env '(map cons ...)' shadows second env 'selectors'
(append (map cons inner-vars inner-tmps) selectors))
(inner-rep
(template-representation inner-pat inner-levels inner-selectors))
(sorted-selectors
(map (lambda (v) (assq v selectors)) inner-vars))
(list-of-selectors
;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs)
(map cdr sorted-selectors)))
(let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors))
(rep2 (template-representation (cddr pat) levels selectors)))
#`(append #,rep1 #,rep2))))
((pair? pat)
#`(cons #,(template-representation (car pat) levels selectors)
#,(template-representation (cdr pat) levels selectors)))))
(define (compile-rule pattern template)
(let ((levels
(pattern-levels pattern))
(selectors
(pattern-selectors pattern)))
(template-representation template levels selectors)))
(define (compile-rules rules)
(if (null? rules)
#`(error "unmatch")
(let ((pattern (car (car rules)))
(template (cadr (car rules))))
#`(if #,(pattern-validator pattern)
#,(compile-rule pattern template)
#,(compile-rules (cdr rules))))))
(define (compile rules)
#`(call-with-current-environment
(lambda (env)
(letrec
((#,'rename (let ((reg (make-register)))
(lambda (x)
2015-07-18 02:28:53 -04:00
(let ((y (reg x)))
(if y
(cdr y)
(let ((id (make-identifier x env)))
(reg x id)
id)))))))
2015-07-08 15:02:55 -04:00
(lambda #,'it
#,(compile-rules rules))))))
(let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
(compile rules)))
(define-syntax (syntax-rules . args)
(if (list? (car args))
#`(syntax-rules ... #,@args)
(let ((ellipsis (car args))
(literals (car (cdr args)))
(rules (cdr (cdr args))))
(compile ellipsis literals rules))))
(define-syntax (define-auxiliary-syntax var)
#`(define-macro #,var
(lambda _
(error "invalid use of auxiliary syntax" '#,var))))
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
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))