picrin/piclib/built-in.scm

921 lines
24 KiB
Scheme

;;; hygienic macros
(define-library (picrin macro)
(import (scheme base))
(define (sc-macro-transformer f)
(lambda (expr use-env mac-env)
(make-syntactic-closure mac-env '() (f expr use-env))))
(define (rsc-macro-transformer f)
(lambda (expr use-env mac-env)
(make-syntactic-closure use-env '() (f expr mac-env))))
(define (er-macro-transformer f)
(lambda (expr use-env mac-env)
(define (rename identifier)
(make-syntactic-closure mac-env '() identifier))
(define (compare x y)
(identifier=? use-env x use-env y))
(make-syntactic-closure use-env '() (f expr rename compare))))
(define (walk f obj)
(if (pair? obj)
(cons (walk f (car obj))
(walk f (cdr obj)))
(f obj)))
;; experimental support
(define (ir-macro-transformer f)
(lambda (expr use-env mac-env)
(define (inject identifier)
(make-syntactic-closure use-env '() identifier))
(define (compare x y)
(identifier=? mac-env x mac-env y))
(define renamed
(walk (lambda (x) (if (symbol? x) (inject x) x)) expr))
(make-syntactic-closure mac-env '() (f renamed inject compare))))
(export sc-macro-transformer
rsc-macro-transformer
er-macro-transformer
ir-macro-transformer))
;;; bootstrap utilities
(define-library (picrin bootstrap-tools)
(import (scheme base))
(define (list . args) args)
(define (caar p) (car (car p)))
(define (cadr p) (car (cdr p)))
(define (cdar p) (cdr (car p)))
(define (cddr p) (cdr (cdr p)))
(define (cadar p) (car (cdar p)))
(define (caddr p) (car (cddr p)))
(define (cdddr p) (cdr (cddr p)))
(define (map f list)
(if (null? list)
list
(cons (f (car list))
(map f (cdr list)))))
(define (append xs ys)
(if (null? xs)
ys
(cons (car xs)
(append (cdr xs) ys))))
(export list map append
caar cadr cdar cddr
cadar caddr cdddr))
;;; core syntaces
(define-library (picrin core-syntax)
(import (scheme base)
(picrin macro)
(picrin bootstrap-tools))
(define-syntax let
(er-macro-transformer
(lambda (expr r compare)
(if (identifier? (cadr expr))
(begin
(define name (cadr expr))
(define bindings (caddr expr))
(define body (cdddr expr))
(list (r 'let) '()
(list (r 'define) name
(cons (r 'lambda) (cons (map car bindings) body)))
(cons name (map cadr bindings))))
(begin
(define bindings (cadr expr))
(define body (cddr expr))
(cons (cons (r 'lambda) (cons (map car bindings) body))
(map cadr bindings)))))))
(define-syntax cond
(er-macro-transformer
(lambda (expr r compare)
(let ((clauses (cdr expr)))
(if (null? clauses)
#f
(list (r 'if) (caar clauses)
(cons (r 'begin) (cdar clauses))
(cons (r 'cond) (cdr clauses))))))))
(define-syntax and
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(if (null? exprs)
#t
(list (r 'if) (car exprs)
(cons (r 'and) (cdr exprs))
#f))))))
(define-syntax or
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(if (null? exprs)
#f
(list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(r 'it)
(cons (r 'or) (cdr exprs)))))))))
(define-syntax quasiquote
(er-macro-transformer
(lambda (expr r compare?)
(let ((x (cadr expr)))
(cond
((symbol? x) (list (r 'quote) x)) ; should test with identifier?
((pair? x) (cond
((compare? (r 'unquote) (car x))
(cadr x))
((and (pair? (car x))
(compare? (r 'unquote-splicing) (caar x)))
(list (r 'append) (cadar x)
(list (r 'quasiquote) (cdr x))))
(#t
(list (r 'cons)
(list (r 'quasiquote) (car x))
(list (r 'quasiquote) (cdr x))))))
(#t x))))))
#;
(define-syntax let*
(ir-macro-transformer
(lambda (form inject compare)
(let ((bindings (cadr form))
(body (cddr form)))
(if (null? bindings)
`(let () ,@body)
`(let ((,(caar bindings)
,@(cdar bindings)))
(let* (,@(cdr bindings))
,@body)))))))
(define-syntax let*
(er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(body (cddr form)))
(if (null? bindings)
`(,(r 'let) () ,@body)
`(,(r 'let) ((,(caar bindings)
,@(cdar bindings)))
(,(r 'let*) (,@(cdr bindings))
,@body)))))))
(define-syntax letrec*
(er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(body (cddr form)))
(let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
(initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
`(,(r 'let) (,@vars)
,@initials
,@body))))))
(define-syntax letrec
(er-macro-transformer
(lambda (form rename compare)
`(,(rename 'letrec*) ,@(cdr form)))))
(define-syntax do
(er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(finish (caddr form))
(body (cdddr form)))
`(,(r 'let) ,(r 'loop) ,(map (lambda (x)
(list (car x) (cadr x)))
bindings)
(,(r 'if) ,(car finish)
(,(r 'begin) ,@(cdr finish))
(,(r 'begin) ,@body
(,(r 'loop) ,@(map (lambda (x)
(if (null? (cddr x))
(car x)
(car (cddr x))))
bindings)))))))))
(define-syntax when
(er-macro-transformer
(lambda (expr rename compare)
(let ((test (cadr expr))
(body (cddr expr)))
`(,(rename 'if) ,test
(,(rename 'begin) ,@body)
#f)))))
(define-syntax unless
(er-macro-transformer
(lambda (expr rename compare)
(let ((test (cadr expr))
(body (cddr expr)))
`(,(rename 'if) ,test
#f
(,(rename 'begin) ,@body))))))
(define-syntax case
(er-macro-transformer
(lambda (expr r compare)
(let ((key (cadr expr))
(clauses (cddr expr)))
`(,(r 'let) ((,(r 'key) ,key))
,(let loop ((clauses clauses))
(if (null? clauses)
#f
`(,(r 'if) (,(r 'or)
,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
(caar clauses)))
(begin ,@(cdar clauses))
,(loop (cdr clauses))))))))))
(define-syntax syntax-error
(er-macro-transformer
(lambda (expr rename compare)
(apply error (cdr expr)))))
(define-syntax define-auxiliary-syntax
(er-macro-transformer
(lambda (expr r c)
`(,(r 'define-syntax) ,(cadr expr)
,(r '(sc-macro-transformer
(lambda (expr env)
(error "invalid use of auxiliary syntax"))))))))
(define-auxiliary-syntax else)
(define-auxiliary-syntax =>)
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define-auxiliary-syntax unquote)
(define-auxiliary-syntax unquote-splicing)
(export let let* letrec letrec*
quasiquote unquote unquote-splicing
and or
cond case else =>
do when unless
_ ... syntax-error))
;;; multiple value
(define-library (picrin multiple-value)
(import (scheme base)
(picrin macro)
(picrin core-syntax)
(picrin bootstrap-tools))
(define *values-tag* (cons #f '()))
(define (values . args)
(if (and (pair? args)
(null? (cdr args)))
(car args)
(cons *values-tag* args)))
(define (call-with-values producer consumer)
(let ((res (producer)))
(if (and (pair? res)
(eq? *values-tag* (car res)))
(apply consumer (cdr res))
(consumer res))))
(define-syntax let*-values
(er-macro-transformer
(lambda (form r c)
(let ((formals (cadr form)))
(if (null? formals)
`(,(r 'let) () ,@(cddr form))
`(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))
(,(r 'lambda) (,@(caar formals))
(,(r 'let*-values) (,@(cdr formals))
,@(cddr form)))))))))
(define-syntax let-values
(er-macro-transformer
(lambda (form r c)
`(,(r 'let*-values) ,@(cdr form)))))
(define-syntax define-values
(er-macro-transformer
(lambda (form r c)
(let ((formals (cadr form)))
`(,(r 'begin)
,@(do ((vars formals (cdr vars))
(defs '()))
((null? vars)
defs)
(set! defs (cons `(,(r 'define) ,(car vars) #f) defs)))
(,(r 'call-with-values)
(,(r 'lambda) () ,@(cddr form))
(,(r 'lambda) (,@(map r formals))
,@(do ((vars formals (cdr vars))
(assn '()))
((null? vars)
assn)
(set! assn (cons `(,(r 'set!) ,(car vars) ,(r (car vars))) assn))))))))))
(export values
call-with-values
let-values
let*-values
define-values))
;;; parameter
(define-library (picrin parameter)
(import (scheme base)
(picrin macro)
(picrin core-syntax)
(picrin bootstrap-tools))
;; reopen (pircin parameter)
;; see src/var.c
(define-syntax parameterize
(er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(body (cddr form)))
(let ((vars (map car bindings)))
`(,(r 'let) (,@(map (lambda (var)
`(,(r var) (,var)))
vars))
,@bindings
(,(r 'let) ((,(r 'result) (begin ,@body)))
,@(map (lambda (var)
`(,(r 'parameter-set!) ,var ,(r var)))
vars)
,(r 'result))))))))
(export parameterize))
(import (picrin macro)
(picrin core-syntax)
(picrin multiple-value)
(picrin parameter))
(export let let* letrec letrec*
quasiquote unquote unquote-splicing
and or
cond case else =>
do when unless
_ ... syntax-error)
(export values
call-with-values
let-values
let*-values
define-values)
(export make-parameter
parameterize)
(define (any pred list)
(if (null? list)
#f
((lambda (it)
(if it
it
(any pred (cdr list))))
(pred (car list)))))
(define (every pred list)
(if (null? list)
#t
(if (pred (car list))
(every pred (cdr list))
#f)))
(define (fold f s xs)
(if (null? xs)
s
(fold f (f (car xs) s) (cdr xs))))
;;; FIXME forward declaration
(define map #f)
;;; 6.2. Numbers
(define (zero? n)
(= n 0))
(define (positive? x)
(> x 0))
(define (negative? x)
(< x 0))
(define (odd? n)
(= 0 (floor-remainder n 2)))
(define (even? n)
(= 1 (floor-remainder n 2)))
(define (min x . args)
(let loop ((pivot x) (rest args))
(if (null? rest)
pivot
(loop (if (< pivot (car rest)) pivot (car rest)) (cdr rest)))))
(define (max x . args)
(let loop ((pivot x) (rest args))
(if (null? rest)
pivot
(loop (if (> pivot (car rest)) pivot (car rest)) (cdr rest)))))
(define (floor/ n m)
(values (floor-quotient n m)
(floor-remainder n m)))
(define (truncate/ n m)
(values (truncate-quotient n m)
(truncate-remainder n m)))
; (import (only (scheme inexact) sqrt))
(import (scheme inexact))
(define (exact-integer-sqrt k)
(let ((n (exact (floor (sqrt k)))))
(values n (- k (square n)))))
(define (gcd n m)
(if (negative? n)
(set! n (- n)))
(if (negative? m)
(set! m (- m)))
(if (> n m)
((lambda (tmp)
(set! n m)
(set! m tmp))
n))
(if (zero? n)
m
(gcd (floor-remainder m n) n)))
(define (lcm n m)
(/ (* n m) (gcd n m)))
(export zero? positive? negative?
odd? even? min max
floor/ truncate/
exact-integer-sqrt
gcd lcm)
;;; 6.3 Booleans
(define (boolean=? . objs)
(or (every (lambda (x) (eq? x #t)) objs)
(every (lambda (x) (eq? x #f)) objs)))
(export boolean=?)
;;; 6.4 Pairs and lists
(define (list? obj)
(if (null? obj)
#t
(if (pair? obj)
(list? (cdr obj))
#f)))
(define (list . args)
args)
(define (caar p)
(car (car p)))
(define (cadr p)
(car (cdr p)))
(define (cdar p)
(cdr (car p)))
(define (cddr p)
(cdr (cdr p)))
(define (make-list k . args)
(if (null? args)
(make-list k #f)
(if (zero? k)
'()
(cons (car args)
(make-list (- k 1) (car args))))))
(define (length list)
(if (null? list)
0
(+ 1 (length (cdr list)))))
(define (append xs ys)
(if (null? xs)
ys
(cons (car xs)
(append (cdr xs) ys))))
(define (reverse list . args)
(if (null? args)
(reverse list '())
(if (null? list)
(car args)
(reverse (cdr list)
(cons (car list) (car args))))))
(define (list-tail list k)
(if (zero? k)
list
(list-tail (cdr list) (- k 1))))
(define (list-ref list k)
(car (list-tail list k)))
(define (list-set! list k obj)
(set-car! (list-tail list k) obj))
(define (list-copy obj)
(if (null? obj)
obj
(cons (car obj)
(list-copy (cdr obj)))))
(define (memq obj list)
(if (null? list)
#f
(if (eq? obj (car list))
list
(memq obj (cdr list)))))
(define (memv obj list)
(if (null? list)
#f
(if (eqv? obj (car list))
list
(memq obj (cdr list)))))
(define (assq obj list)
(if (null? list)
#f
(if (eq? obj (caar list))
(car list)
(assq obj (cdr list)))))
(define (assv obj list)
(if (null? list)
#f
(if (eqv? obj (caar list))
(car list)
(assq obj (cdr list)))))
(define (member obj list . opts)
(let ((compare (if (null? opts) equal? (car opts))))
(if (null? list)
#f
(if (compare obj (car list))
list
(member obj (cdr list) compare)))))
(define (assoc obj list . opts)
(let ((compare (if (null? opts) equal? (car opts))))
(if (null? list)
#f
(if (compare obj (caar list))
(car list)
(assoc obj (cdr list) compare)))))
(export list? list caar cadr cdar cddr
make-list length append reverse
list-tail list-ref list-set! list-copy
memq memv member
assq assv assoc)
;;; 6.5. Symbols
(define (symbol=? . objs)
(let ((sym (car objs)))
(if (symbol? sym)
(every (lambda (x)
(and (symbol? x)
(eq? x sym)))
(cdr objs))
#f)))
(export symbol=?)
;;; 6.6 Characters
(define-macro (define-char-transitive-predicate name op)
`(define (,name . cs)
(apply ,op (map char->integer cs))))
(define-char-transitive-predicate char=? =)
(define-char-transitive-predicate char<? <)
(define-char-transitive-predicate char>? >)
(define-char-transitive-predicate char<=? <=)
(define-char-transitive-predicate char>=? >=)
(export char=?
char<?
char>?
char<=?
char>=?)
;;; 6.7 String
(define (string . objs)
(let ((len (length objs)))
(let ((v (make-string len)))
(do ((i 0 (+ i 1))
(l objs (cdr l)))
((= i len)
v)
(string-set! v i (car l))))))
(define (string->list string . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length string))))
(do ((i start (+ i 1))
(res '()))
((= i end)
(reverse res))
(set! res (cons (string-ref string i) res)))))
(define (list->string list)
(apply string list))
(define (string-copy! to at from . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length from))))
(do ((i at (+ i 1))
(j start (+ j 1)))
((= j end))
(string-set! to i (string-ref from j)))))
(define (string-copy v . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length v))))
(let ((res (make-string (string-length v))))
(string-copy! res 0 v start end)
res)))
(define (string-append . vs)
(define (string-append-2-inv w v)
(let ((res (make-string (+ (string-length v) (string-length w)))))
(string-copy! res 0 v)
(string-copy! res (string-length v) w)
res))
(fold string-append-2-inv #() vs))
(define (string-fill! v fill . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length v))))
(do ((i start (+ i 1)))
((= i end)
#f)
(string-set! v i fill))))
(export string string->list list->string
string-copy! string-copy
string-append string-fill!)
;;; 6.8. Vector
(define (vector . objs)
(let ((len (length objs)))
(let ((v (make-vector len)))
(do ((i 0 (+ i 1))
(l objs (cdr l)))
((= i len)
v)
(vector-set! v i (car l))))))
(define (vector->list vector . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(vector-length vector))))
(do ((i start (+ i 1))
(res '()))
((= i end)
(reverse res))
(set! res (cons (vector-ref vector i) res)))))
(define (list->vector list)
(apply vector list))
(define (vector-copy! to at from . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(vector-length from))))
(do ((i at (+ i 1))
(j start (+ j 1)))
((= j end))
(vector-set! to i (vector-ref from j)))))
(define (vector-copy v . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(vector-length v))))
(let ((res (make-vector (vector-length v))))
(vector-copy! res 0 v start end)
res)))
(define (vector-append . vs)
(define (vector-append-2-inv w v)
(let ((res (make-vector (+ (vector-length v) (vector-length w)))))
(vector-copy! res 0 v)
(vector-copy! res (vector-length v) w)
res))
(fold vector-append-2-inv #() vs))
(define (vector-fill! v fill . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(vector-length v))))
(do ((i start (+ i 1)))
((= i end)
#f)
(vector-set! v i fill))))
(define (vector->string . args)
(list->string (apply vector->list args)))
(define (string->vector . args)
(list->vector (apply string->list args)))
(export vector vector->list list->vector
vector-copy! vector-copy
vector-append vector-fill!
vector->string string->vector)
;;; 6.9 bytevector
(define (bytevector . objs)
(let ((len (length objs)))
(let ((v (make-bytevector len)))
(do ((i 0 (+ i 1))
(l objs (cdr l)))
((= i len)
v)
(bytevector-u8-set! v i (car l))))))
(define (bytevector-copy! to at from . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(bytevector-length from))))
(do ((i at (+ i 1))
(j start (+ j 1)))
((= j end))
(bytevector-u8-set! to i (bytevector-u8-ref from j)))))
(define (bytevector-copy v . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(bytevector-length v))))
(let ((res (make-bytevector (bytevector-length v))))
(bytevector-copy! res 0 v start end)
res)))
(define (bytevector-append . vs)
(define (bytevector-append-2-inv w v)
(let ((res (make-bytevector (+ (bytevector-length v) (bytevector-length w)))))
(bytevector-copy! res 0 v)
(bytevector-copy! res (bytevector-length v) w)
res))
(fold bytevector-append-2-inv #() vs))
(define (bytevector->list v start end)
(do ((i start (+ i 1))
(res '()))
((= i end)
(reverse res))
(set! res (cons (bytevector-u8-ref v i) res))))
(define (list->bytevector v)
(apply bytevector v))
(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)))))
(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)))))
(export bytevector
bytevector-copy!
bytevector-copy
bytevector-append
utf8->string
string->utf8)
;;; 6.10 control features
(set! map
(lambda (f list . lists)
(define (single-map f list)
(if (null? list)
'()
(cons (f (car list))
(map f (cdr list)))))
(define (multiple-map f lists)
(if (any null? lists)
'()
(cons (apply f (single-map car lists))
(multiple-map f (single-map cdr lists)))))
(if (null? lists)
(single-map f list)
(multiple-map f (cons list lists)))))
(define (for-each f list . lists)
(define (single-for-each f list)
(if (null? list)
#f
(begin
(f (car list))
(single-for-each f (cdr list)))))
(define (multiple-for-each f lists)
(if (any null? lists)
#f
(begin
(apply f (map car lists))
(multiple-for-each f (map cdr lists)))))
(if (null? lists)
(single-for-each f list)
(multiple-for-each f (cons list lists))))
(define (string-map f v . vs)
(let* ((len (fold min (string-length v) (map string-length vs)))
(vec (make-string len)))
(let loop ((n 0))
(if (= n len)
vec
(begin (string-set! vec n
(apply f (cons (string-ref v n)
(map (lambda (v) (string-ref v n)) vs))))
(loop (+ n 1)))))))
(define (string-for-each f v . vs)
(let* ((len (fold min (string-length v) (map string-length vs))))
(let loop ((n 0))
(unless (= n len)
(apply f (string-ref v n)
(map (lambda (v) (string-ref v n)) vs))
(loop (+ n 1))))))
(define (vector-map f v . vs)
(let* ((len (fold min (vector-length v) (map vector-length vs)))
(vec (make-vector len)))
(let loop ((n 0))
(if (= n len)
vec
(begin (vector-set! vec n
(apply f (cons (vector-ref v n)
(map (lambda (v) (vector-ref v n)) vs))))
(loop (+ n 1)))))))
(define (vector-for-each f v . vs)
(let* ((len (fold min (vector-length v) (map vector-length vs))))
(let loop ((n 0))
(unless (= n len)
(apply f (vector-ref v n)
(map (lambda (v) (vector-ref v n)) vs))
(loop (+ n 1))))))
(export map for-each
string-map string-for-each
vector-map vector-for-each)
;;; 6.13. Input and output
(define (call-with-port port proc)
(dynamic-wind
(lambda () #f)
(lambda () (proc port))
(lambda () (close-port port))))
(export call-with-port)