conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP

This commit is contained in:
Yuichi Nishiwaki 2014-09-08 20:20:08 +09:00
parent c3ef97992d
commit 3919c17fdc
20 changed files with 1044 additions and 1425 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extlib/benz

@ -1 +1 @@
Subproject commit b8b5743589ccbed555805d768d5c840aad350499
Subproject commit a2848f3eafdbe3a4579dd4c8054ab7e3b62e6812

14
piclib/CMakeLists.txt
View File

@ -1,14 +1,14 @@
list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/syntax-rules.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/read.scm
@ -17,6 +17,10 @@ list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/eval.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/inexact.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/load.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/process-context.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/time.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm

31
piclib/picrin/array.scm
View File

@ -1,6 +1,5 @@
(define-library (picrin array)
(import (scheme base)
(picrin base)
(import (picrin base)
(picrin record))
(define-record-type <array>
@ -11,6 +10,11 @@
(head array-head set-array-head!)
(tail array-tail set-array-tail!))
(define (floor-remainder i j)
(call-with-values (lambda () (floor/ i j))
(lambda (q r)
r)))
(define (translate ary i)
(floor-remainder i (array-size ary)))
@ -39,7 +43,7 @@
(if (null? rest)
(make-array 0)
(let ((capacity (car rest))
(ary (create-array (vector) 0 0 0)))
(ary (create-array (make-vector 0) 0 0 0)))
(array-reserve! ary capacity)
ary)))
@ -90,16 +94,17 @@
(for-each proc (array->list ary)))
(define-record-writer (<array> array)
(call-with-port (open-output-string)
(lambda (port)
(display "#.(array" port)
(array-for-each
(lambda (obj)
(display " " port)
(write obj port))
array)
(display ")" port)
(get-output-string port))))
(let ((port (open-output-string)))
(display "#.(array" port)
(array-for-each
(lambda (obj)
(display " " port)
(write obj port))
array)
(display ")" port)
(let ((str (get-output-string port)))
(close-port port)
str)))
(export make-array
array

580
piclib/picrin/base.scm
View File

@ -1,4 +1,307 @@
(define-library (picrin base)
(import (picrin macro))
(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)
(list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_
(list (r '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)
(define-syntax let
(er-macro-transformer
(lambda (expr r compare)
(if (symbol? (cadr expr))
(begin
(define name (car (cdr expr)))
(define bindings (car (cdr (cdr expr))))
(define body (cdr (cdr (cdr expr))))
(list (r 'let) '()
(list (r 'define) name
(cons (r 'lambda) (cons (map car bindings) body)))
(cons name (map cadr bindings))))
(begin
(set! bindings (cadr expr))
(set! 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
(begin
(define clause (car clauses))
(if (compare (r 'else) (car clause))
(cons (r 'begin) (cdr clause))
(if (if (>= (length clause) 2)
(compare (r '=>) (list-ref clause 1))
#f)
(list (r 'let) (list (list (r 'x) (car clause)))
(list (r 'if) (r 'x)
(list (list-ref clause 2) (r 'x))
(cons (r 'cond) (cdr clauses))))
(list (r 'if) (car clause)
(cons (r 'begin) (cdr clause))
(cons (r 'cond) (cdr clauses)))))))))))
(define-syntax and
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(cond
((null? exprs)
#t)
((= (length exprs) 1)
(car exprs))
(else
(list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(cons (r 'and) (cdr exprs))
(r 'it)))))))))
(define-syntax or
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(cond
((null? exprs)
#t)
((= (length exprs) 1)
(car exprs))
(else
(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 (form rename compare)
(define (quasiquote? form)
(and (pair? form) (compare (car form) (rename 'quasiquote))))
(define (unquote? form)
(and (pair? form) (compare (car form) (rename 'unquote))))
(define (unquote-splicing? form)
(and (pair? form) (pair? (car form))
(compare (car (car form)) (rename 'unquote-splicing))))
(define (qq depth expr)
(cond
;; unquote
((unquote? expr)
(if (= depth 1)
(car (cdr expr))
(list (rename 'list)
(list (rename 'quote) (rename 'unquote))
(qq (- depth 1) (car (cdr expr))))))
;; unquote-splicing
((unquote-splicing? expr)
(if (= depth 1)
(list (rename 'append)
(car (cdr (car expr)))
(qq depth (cdr expr)))
(list (rename 'cons)
(list (rename 'list)
(list (rename 'quote) (rename 'unquote-splicing))
(qq (- depth 1) (car (cdr (car expr)))))
(qq depth (cdr expr)))))
;; quasiquote
((quasiquote? expr)
(list (rename 'list)
(list (rename 'quote) (rename 'quasiquote))
(qq (+ depth 1) (car (cdr expr)))))
;; list
((pair? expr)
(list (rename 'cons)
(qq depth (car expr))
(qq depth (cdr expr))))
;; vector
((vector? expr)
(list (rename 'list->vector) (qq depth (vector->list expr))))
;; simple datum
(else
(list (rename 'quote) expr))))
(let ((x (cadr form)))
(qq 1 x)))))
(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 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 compare)
(let ((formal (cadr form))
(exprs (cddr form)))
`(,(r 'begin)
,@(let loop ((formal formal))
(if (not (pair? formal))
(if (symbol? formal)
`((,(r 'define) ,formal #f))
'())
`((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))
(,(r 'call-with-values) (,(r 'lambda) () ,@exprs)
(,(r 'lambda) ,(r 'args)
,@(let loop ((formal formal) (args (r 'args)))
(if (not (pair? formal))
(if (symbol? formal)
`((,(r 'set!) ,formal ,args))
'())
`((,(r 'set!) ,(car formal) (,(r 'car) ,args))
,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))
(define-syntax do
(er-macro-transformer
(lambda (form r compare)
(let ((bindings (car (cdr form)))
(finish (car (cdr (cdr form))))
(body (cdr (cdr (cdr 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
(begin
(define clause (car clauses))
`(,(r 'if) ,(if (compare (r 'else) (car clause))
'#t
`(,(r 'or)
,@(map (lambda (x)
`(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
(car clause))))
,(if (compare (r '=>) (list-ref clause 1))
`(,(list-ref clause 2) ,(r 'key))
`(,(r 'begin) ,@(cdr clause)))
,(loop (cdr clauses)))))))))))
(define-syntax letrec-syntax
(er-macro-transformer
(lambda (form r c)
(let ((formal (car (cdr form)))
(body (cdr (cdr form))))
`(let ()
,@(map (lambda (x)
`(,(r 'define-syntax) ,(car x) ,(cadr x)))
formal)
,@body)))))
(define-syntax let-syntax
(er-macro-transformer
(lambda (form r c)
`(,(r 'letrec-syntax) ,@(cdr form)))))
(define-syntax include
(letrec ((read-file
(lambda (filename)
(let ((port (open-input-file filename)))
(dynamic-wind
(lambda () #f)
(lambda ()
(let loop ((expr (read port)) (exprs '()))
(if (eof-object? expr)
(reverse exprs)
(loop (read port) (cons expr exprs)))))
(lambda ()
(close-port port)))))))
(er-macro-transformer
(lambda (form rename compare)
(let ((filenames (cdr form)))
(let ((exprs (apply append (map read-file filenames))))
`(,(rename 'begin) ,@exprs)))))))
(export define
lambda
if
@ -7,6 +310,16 @@
begin
define-syntax)
(export let let* letrec letrec*
let-values let*-values define-values
quasiquote unquote unquote-splicing
and or
cond case else =>
do when unless
let-syntax letrec-syntax
include
_ ... syntax-error)
(export eq?
eqv?
equal?)
@ -146,8 +459,13 @@
output-port?
textual-port?
binary-port?
close-port
open-input-file
open-output-file
open-binary-input-file
open-binary-output-file
open-input-string
open-output-string
get-output-string
@ -188,6 +506,7 @@
make-identifier)
(export call-with-current-continuation
call/cc
continue
dynamic-wind
values
@ -216,255 +535,18 @@
write-shared
display)
(define-syntax syntax-error
(er-macro-transformer
(lambda (expr rename compare)
(apply error (cdr expr)))))
(export command-line
exit
emergency-exit
file-exists?
delete-file
get-environment-variable
get-environment-variables)
(define-syntax define-auxiliary-syntax
(er-macro-transformer
(lambda (expr r c)
(list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_
(list (r 'error) "invalid use of auxiliary syntax"))))))
(export current-second
current-jiffy
jiffies-per-second)
(define-auxiliary-syntax else)
(define-auxiliary-syntax =>)
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define-auxiliary-syntax unquote)
(define-auxiliary-syntax unquote-splicing)
(export eval)
(define-syntax let
(er-macro-transformer
(lambda (expr r compare)
(if (symbol? (cadr expr))
(begin
(define name (car (cdr expr)))
(define bindings (car (cdr (cdr expr))))
(define body (cdr (cdr (cdr expr))))
(list (r 'let) '()
(list (r 'define) name
(cons (r 'lambda) (cons (map car bindings) body)))
(cons name (map cadr bindings))))
(begin
(set! bindings (cadr expr))
(set! 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
(begin
(define clause (car clauses))
(if (compare (r 'else) (car clause))
(cons (r 'begin) (cdr clause))
(if (if (>= (length clause) 2)
(compare (r '=>) (list-ref clause 1))
#f)
(list (r 'let) (list (list (r 'x) (car clause)))
(list (r 'if) (r 'x)
(list (list-ref clause 2) (r 'x))
(cons (r 'cond) (cdr clauses))))
(list (r 'if) (car clause)
(cons (r 'begin) (cdr clause))
(cons (r 'cond) (cdr clauses)))))))))))
(define-syntax and
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(cond
((null? exprs)
#t)
((= (length exprs) 1)
(car exprs))
(else
(list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(cons (r 'and) (cdr exprs))
(r 'it)))))))))
(define-syntax or
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(cond
((null? exprs)
#t)
((= (length exprs) 1)
(car exprs))
(else
(list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(r 'it)
(cons (r 'or) (cdr exprs))))))))))
(define-syntax quasiquote
(ir-macro-transformer
(lambda (form inject compare)
(define (quasiquote? form)
(and (pair? form) (compare (car form) 'quasiquote)))
(define (unquote? form)
(and (pair? form) (compare (car form) 'unquote)))
(define (unquote-splicing? form)
(and (pair? form) (pair? (car form))
(compare (car (car form)) 'unquote-splicing)))
(define (qq depth expr)
(cond
;; unquote
((unquote? expr)
(if (= depth 1)
(car (cdr expr))
(list 'list
(list 'quote (inject 'unquote))
(qq (- depth 1) (car (cdr expr))))))
;; unquote-splicing
((unquote-splicing? expr)
(if (= depth 1)
(list 'append
(car (cdr (car expr)))
(qq depth (cdr expr)))
(list 'cons
(list 'list
(list 'quote (inject 'unquote-splicing))
(qq (- depth 1) (car (cdr (car expr)))))
(qq depth (cdr expr)))))
;; quasiquote
((quasiquote? expr)
(list 'list
(list 'quote (inject 'quasiquote))
(qq (+ depth 1) (car (cdr expr)))))
;; list
((pair? expr)
(list 'cons
(qq depth (car expr))
(qq depth (cdr expr))))
;; vector
((vector? expr)
(list 'list->vector (qq depth (vector->list expr))))
;; simple datum
(else
(list 'quote expr))))
(let ((x (cadr form)))
(qq 1 x)))))
(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 (car (cdr form)))
(finish (car (cdr (cdr form))))
(body (cdr (cdr (cdr 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
(begin
(define clause (car clauses))
`(,(r 'if) ,(if (compare (r 'else) (car clause))
'#t
`(,(r 'or)
,@(map (lambda (x)
`(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
(car clause))))
,(if (compare (r '=>) (list-ref clause 1))
`(,(list-ref clause 2) ,(r 'key))
`(,(r 'begin) ,@(cdr clause)))
,(loop (cdr clauses)))))))))))
(define-syntax letrec-syntax
(er-macro-transformer
(lambda (form r c)
(let ((formal (car (cdr form)))
(body (cdr (cdr form))))
`(let ()
,@(map (lambda (x)
`(,(r 'define-syntax) ,(car x) ,(cadr x)))
formal)
,@body)))))
(define-syntax let-syntax
(er-macro-transformer
(lambda (form r c)
`(,(r 'letrec-syntax) ,@(cdr form)))))
(export let let* letrec letrec*
quasiquote unquote unquote-splicing
and or
cond case else =>
do when unless
let-syntax letrec-syntax
include
_ ... syntax-error))
(export load))

3
piclib/picrin/dictionary.scm
View File

@ -1,6 +1,5 @@
(define-library (picrin dictionary)
(import (scheme base)
(picrin base))
(import (picrin base))
(define (dictionary-map proc dict)
(let ((kvs '()))

8
piclib/picrin/macro.scm
View File

@ -1,5 +1,3 @@
;;; Hygienic Macros
(define-library (picrin macro)
(import (picrin base))
@ -109,8 +107,8 @@
(rename sym)))))
(f (walk inject expr) inject compare))))
(define (strip-syntax form)
(walk ungensym form))
;; (define (strip-syntax form)
;; (walk ungensym form))
(define-syntax define-macro
(er-macro-transformer
@ -136,5 +134,5 @@
rsc-macro-transformer
er-macro-transformer
ir-macro-transformer
strip-syntax
;; strip-syntax
define-macro))

19
piclib/picrin/record.scm
View File

@ -1,6 +1,6 @@
(define-library (picrin record)
(import (picrin base)
(scheme base))
(picrin macro))
;; define-record-writer
@ -8,14 +8,15 @@
(record-set! record-type 'writer writer))
(define-syntax define-record-writer
(syntax-rules ()
((_ (type obj) body ...)
(set-record-writer! type
(lambda (obj)
body ...)))
((_ type writer)
(set-record-writer! type
writer))))
(er-macro-transformer
(lambda (form r compare)
(let ((formal (cadr form)))
(if (pair? formal)
`(,(r 'set-record-writer!) ,(car formal)
(,(r 'lambda) (,(cadr formal))
,@(cddr form)))
`(,(r 'set-record-writer!) ,formal
,@(cddr form)))))))
;; define-record-type

335
piclib/picrin/syntax-rules.scm Normal file
View File

@ -0,0 +1,335 @@
(define-library (picrin syntax-rules)
(import (picrin base)
(picrin macro))
(define (walk proc expr)
(cond
((null? expr)
'())
((pair? expr)
(cons (walk proc (car expr))
(walk proc (cdr expr))))
((vector? expr)
(list->vector (map proc (vector->list expr))))
(else
(proc expr))))
(define (flatten expr)
(let ((list '()))
(walk
(lambda (x)
(set! list (cons x list)))
expr)
(reverse list)))
(define (reverse* l)
;; (reverse* '(a b c d . e)) => (e d c b a)
(let loop ((a '())
(d l))
(if (pair? d)
(loop (cons (car d) a) (cdr d))
(cons d a))))
(define (every? pred l)
(if (null? l)
#t
(and (pred (car l)) (every? pred (cdr l)))))
(define-syntax syntax-rules
(er-macro-transformer
(lambda (form r compare)
(define _define (r 'define))
(define _let (r 'let))
(define _if (r 'if))
(define _begin (r 'begin))
(define _lambda (r 'lambda))
(define _set! (r 'set!))
(define _not (r 'not))
(define _and (r 'and))
(define _car (r 'car))
(define _cdr (r 'cdr))
(define _cons (r 'cons))
(define _pair? (r 'pair?))
(define _null? (r 'null?))
(define _symbol? (r 'symbol?))
(define _vector? (r 'vector?))
(define _eqv? (r 'eqv?))
(define _string=? (r 'string=?))
(define _map (r 'map))
(define _vector->list (r 'vector->list))
(define _list->vector (r 'list->vector))
(define _quote (r 'quote))
(define _quasiquote (r 'quasiquote))
(define _unquote (r 'unquote))
(define _unquote-splicing (r 'unquote-splicing))
(define _syntax-error (r 'syntax-error))
(define _call/cc (r 'call/cc))
(define _er-macro-transformer (r 'er-macro-transformer))
(define (var->sym v)
(let loop ((cnt 0)
(v v))
(if (symbol? v)
(string->symbol
(string-append (symbol->string v) "/" (number->string cnt)))
(loop (+ 1 cnt) (car v)))))
(define push-var list)
(define (compile-match ellipsis literals pattern)
(letrec ((compile-match-base
(lambda (pattern)
(cond ((member pattern literals compare)
(values
`(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
#f
(exit #f))
'()))
((compare pattern (r '_)) (values #f '()))
((and ellipsis (compare pattern ellipsis))
(values `(,_syntax-error "invalid pattern") '()))
((symbol? pattern)
(values `(,_set! ,(var->sym pattern) expr) (list pattern)))
((pair? pattern)
(compile-match-list pattern))
((vector? pattern)
(compile-match-vector pattern))
((string? pattern)
(values
`(,_if (,_not (,_string=? ',pattern expr))
(exit #f))
'()))
(else
(values
`(,_if (,_not (,_eqv? ',pattern expr))
(exit #f))
'())))))
(compile-match-list
(lambda (pattern)
(let loop ((pattern pattern)
(matches '())
(vars '())
(accessor 'expr))
(cond ;; (hoge)
((not (pair? (cdr pattern)))
(let*-values (((match1 vars1) (compile-match-base (car pattern)))
((match2 vars2) (compile-match-base (cdr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_if (,_pair? ,accessor)
(,_begin
(,_let ((expr (,_car ,accessor)))
,match1)
(,_let ((expr (,_cdr ,accessor)))
,match2))
(exit #f)))
(append vars (append vars1 vars2)))))
;; (hoge ... rest args)
((and ellipsis (compare (cadr pattern) ellipsis))
(let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr (,_let loop ((a ())
(d ,accessor))
(,_if (,_pair? d)
(loop (,_cons (,_car d) a) (,_cdr d))
(,_cons d a)))))
,match-r))
(append vars vars-r))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_if (,_pair? ,accessor)
(,_let ((expr (,_car ,accessor)))
,match1)
(exit #f))
matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-list-reverse
(lambda (pattern)
(let loop ((pattern (reverse* pattern))
(matches '())
(vars '())
(accessor 'expr))
(cond ((and ellipsis (compare (car pattern) ellipsis))
(let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr ,accessor))
,match1))
(append vars vars1))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-ellipsis
(lambda (pattern)
(let-values (((match vars) (compile-match-base pattern)))
(values
`(,_let loop ((expr expr))
(,_if (,_not (,_null? expr))
(,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)
(,_let ((expr (,_car expr)))
,match)
,@(map
(lambda (var)
`(,_set! ,(var->sym (push-var var))
(,_cons ,(var->sym var) ,(var->sym (push-var var)))))
vars)
(loop (,_cdr expr)))))
(map push-var vars)))))
(compile-match-vector
(lambda (pattern)
(let-values (((match vars) (compile-match-base (vector->list pattern))))
(values
`(,_if (,_vector? expr)
(,_let ((expr (,_vector->list expr)))
,match)
(exit #f))
vars)))))
(let-values (((match vars) (compile-match-base (cdr pattern))))
(values `(,_let ((expr (,_cdr expr)))
,match
#t)
vars))))
;;; compile expand
(define (compile-expand ellipsis reserved template)
(letrec ((compile-expand-base
(lambda (template ellipsis-valid)
(cond ((member template reserved eq?)
(values (var->sym template) (list template)))
((symbol? template)
(values `(rename ',template) '()))
((pair? template)
(compile-expand-list template ellipsis-valid))
((vector? template)
(compile-expand-vector template ellipsis-valid))
(else
(values `',template '())))))
(compile-expand-list
(lambda (template ellipsis-valid)
(let loop ((template template)
(expands '())
(vars '()))
(cond ;; (... hoge)
((and ellipsis-valid
(pair? template)
(compare (car template) ellipsis))
(if (and (pair? (cdr template)) (null? (cddr template)))
(compile-expand-base (cadr template) #f)
(values '(,_syntax-error "invalid template") '())))
;; hoge
((not (pair? template))
(let-values (((expand1 vars1)
(compile-expand-base template ellipsis-valid)))
(values
`(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
(append vars vars1))))
;; (a ... rest syms)
((and ellipsis-valid
(pair? (cdr template))
(compare (cadr template) ellipsis))
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cddr template)
(cons
`(,_unquote-splicing
(,_map (,_lambda ,(map var->sym vars1) ,expand1)
,@(map (lambda (v) (var->sym (push-var v))) vars1)))
expands)
(append vars (map push-var vars1)))))
(else
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cdr template)
(cons
`(,_unquote ,expand1)
expands)
(append vars vars1))))))))
(compile-expand-vector
(lambda (template ellipsis-valid)
(let-values (((expand1 vars1)
(compile-expand-base (vector->list template) ellipsis-valid)))
(values
`(,_list->vector ,expand1)
vars1)))))
(compile-expand-base template ellipsis)))
(define (check-vars vars-pattern vars-template)
;;fixme
#t)
(define (compile-rule ellipsis literals rule)
(let ((pattern (car rule))
(template (cadr rule)))
(let*-values (((match vars-match)
(compile-match ellipsis literals pattern))
((expand vars-expand)
(compile-expand ellipsis (flatten vars-match) template)))
(if (check-vars vars-match vars-expand)
(list vars-match match expand)
'mismatch))))
(define (expand-clauses clauses rename)
(cond ((null? clauses)
`(,_quote (syntax-error "no matching pattern")))
((compare (car clauses) 'mismatch)
`(,_syntax-error "invalid rule"))
(else
(let ((vars (list-ref (car clauses) 0))
(match (list-ref (car clauses) 1))
(expand (list-ref (car clauses) 2)))
`(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
(,_let ((result (,_call/cc (,_lambda (exit) ,match))))
(,_if result
,expand
,(expand-clauses (cdr clauses) rename))))))))
(define (normalize-form form)
(if (and (list? form) (>= (length form) 2))
(let ((ellipsis '...)
(literals (cadr form))
(rules (cddr form)))
(when (symbol? literals)
(set! ellipsis literals)
(set! literals (car rules))
(set! rules (cdr rules)))
(if (and (symbol? ellipsis)
(list? literals)
(every? symbol? literals)
(list? rules)
(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
(if (member ellipsis literals compare)
`(syntax-rules #f ,literals ,@rules)
`(syntax-rules ,ellipsis ,literals ,@rules))
#f))
#f))
(let ((form (normalize-form form)))
(if form
(let ((ellipsis (list-ref form 1))
(literals (list-ref form 2))
(rules (list-tail form 3)))
(let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
rules)))
`(,_er-macro-transformer
(,_lambda (expr rename cmp)
,(expand-clauses clauses r)))))
`(,_syntax-error "malformed syntax-rules"))))))
(export syntax-rules))

7
piclib/picrin/test.scm
View File

@ -1,7 +1,6 @@
(define-library (picrin test)
(import (scheme base)
(scheme process-context)
(picrin base))
(import (picrin base)
(picrin syntax-rules))
(define test-counter 0)
(define counter 0)
@ -77,7 +76,7 @@
(length fails))
(define (test-exit)
(exit (zero? (test-failure-count))))
(exit (= (test-failure-count) 0)))
(define-syntax test-syntax-error
(syntax-rules ()

867
piclib/scheme/base.scm
View File

@ -1,429 +1,56 @@
(define-library (scheme base)
(import (picrin base)
(picrin macro))
(picrin macro)
(picrin record)
(picrin syntax-rules))
(export define
set!
lambda
quote
if
begin
define-syntax)
(export else => _ ...)
;; core syntax
;; 4.1.2. Literal expressions
(import (scheme file))
(export quote)
(define-syntax include
(letrec ((read-file
(lambda (filename)
(let ((port (open-input-file filename)))
(dynamic-wind
(lambda () #f)
(lambda ()
(let loop ((expr (read port)) (exprs '()))
(if (eof-object? expr)
(reverse exprs)
(loop (read port) (cons expr exprs)))))
(lambda ()
(close-port port)))))))
(er-macro-transformer
(lambda (form rename compare)
(let ((filenames (cdr form)))
(let ((exprs (apply append (map read-file filenames))))
`(,(rename 'begin) ,@exprs)))))))
;; 4.1.4. Procedures
(export let let* letrec letrec*
quasiquote unquote unquote-splicing
and or
cond case else =>
do when unless
let-syntax letrec-syntax
include
_ ... syntax-error)
(export lambda)
;; 4.1.5. Conditionals
;; utility functions
(export if)
(define (walk proc expr)
(cond
((null? expr)
'())
((pair? expr)
(cons (walk proc (car expr))
(walk proc (cdr expr))))
((vector? expr)
(list->vector (map proc (vector->list expr))))
(else
(proc expr))))
;; 4.1.6. Assignments
(define (flatten expr)
(let ((list '()))
(walk
(lambda (x)
(set! list (cons x list)))
expr)
(reverse list)))
(export set!)
(define (reverse* l)
;; (reverse* '(a b c d . e)) => (e d c b a)
(let loop ((a '())
(d l))
(if (pair? d)
(loop (cons (car d) a) (cdr d))
(cons d a))))
;; 4.1.7. Inclusion
(define (every? pred l)
(if (null? l)
#t
(and (pred (car l)) (every? pred (cdr l)))))
(export include)
;; 4.2.1. Conditionals
;; extra syntax
(export cond
case
and
or
when
unless)
(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)))))))))
;; 4.2.2. Binding constructs
(define-syntax let-values
(er-macro-transformer
(lambda (form r c)
`(,(r 'let*-values) ,@(cdr form)))))
(export let
let*
letrec
letrec*
let-values
let*-values)
(define uniq
(let ((counter 0))
(lambda (x)
(let ((sym (string->symbol (string-append "var$" (number->string counter)))))
(set! counter (+ counter 1))
sym))))
;; 4.2.3. Sequencing
(define-syntax define-values
(ir-macro-transformer
(lambda (form inject compare)
(let* ((formal (cadr form))
(formal* (walk uniq formal))
(exprs (cddr form)))
`(begin
,@(map
(lambda (var) `(define ,var #f))
(flatten formal))
(call-with-values (lambda () ,@exprs)
(lambda ,formal*
,@(map
(lambda (var val) `(set! ,var ,val))
(flatten formal)
(flatten formal*)))))))))
(export begin)
(export let-values
let*-values
define-values)
(define-syntax syntax-rules
(er-macro-transformer
(lambda (form r compare)
(define _define (r 'define))
(define _let (r 'let))
(define _if (r 'if))
(define _begin (r 'begin))
(define _lambda (r 'lambda))
(define _set! (r 'set!))
(define _not (r 'not))
(define _and (r 'and))
(define _car (r 'car))
(define _cdr (r 'cdr))
(define _cons (r 'cons))
(define _pair? (r 'pair?))
(define _null? (r 'null?))
(define _symbol? (r 'symbol?))
(define _vector? (r 'vector?))
(define _eqv? (r 'eqv?))
(define _string=? (r 'string=?))
(define _map (r 'map))
(define _vector->list (r 'vector->list))
(define _list->vector (r 'list->vector))
(define _quote (r 'quote))
(define _quasiquote (r 'quasiquote))
(define _unquote (r 'unquote))
(define _unquote-splicing (r 'unquote-splicing))
(define _syntax-error (r 'syntax-error))
(define _call/cc (r 'call/cc))
(define _er-macro-transformer (r 'er-macro-transformer))
(define (var->sym v)
(let loop ((cnt 0)
(v v))
(if (symbol? v)
(string->symbol
(string-append (symbol->string v) "/" (number->string cnt)))
(loop (+ 1 cnt) (car v)))))
(define push-var list)
(define (compile-match ellipsis literals pattern)
(letrec ((compile-match-base
(lambda (pattern)
(cond ((member pattern literals compare)
(values
`(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
#f
(exit #f))
'()))
((compare pattern (r '_)) (values #f '()))
((and ellipsis (compare pattern ellipsis))
(values `(,_syntax-error "invalid pattern") '()))
((symbol? pattern)
(values `(,_set! ,(var->sym pattern) expr) (list pattern)))
((pair? pattern)
(compile-match-list pattern))
((vector? pattern)
(compile-match-vector pattern))
((string? pattern)
(values
`(,_if (,_not (,_string=? ',pattern expr))
(exit #f))
'()))
(else
(values
`(,_if (,_not (,_eqv? ',pattern expr))
(exit #f))
'())))))
(compile-match-list
(lambda (pattern)
(let loop ((pattern pattern)
(matches '())
(vars '())
(accessor 'expr))
(cond ;; (hoge)
((not (pair? (cdr pattern)))
(let*-values (((match1 vars1) (compile-match-base (car pattern)))
((match2 vars2) (compile-match-base (cdr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_if (,_pair? ,accessor)
(,_begin
(,_let ((expr (,_car ,accessor)))
,match1)
(,_let ((expr (,_cdr ,accessor)))
,match2))
(exit #f)))
(append vars (append vars1 vars2)))))
;; (hoge ... rest args)
((and ellipsis (compare (cadr pattern) ellipsis))
(let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr (,_let loop ((a ())
(d ,accessor))
(,_if (,_pair? d)
(loop (,_cons (,_car d) a) (,_cdr d))
(,_cons d a)))))
,match-r))
(append vars vars-r))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_if (,_pair? ,accessor)
(,_let ((expr (,_car ,accessor)))
,match1)
(exit #f))
matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-list-reverse
(lambda (pattern)
(let loop ((pattern (reverse* pattern))
(matches '())
(vars '())
(accessor 'expr))
(cond ((and ellipsis (compare (car pattern) ellipsis))
(let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr ,accessor))
,match1))
(append vars vars1))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-ellipsis
(lambda (pattern)
(let-values (((match vars) (compile-match-base pattern)))
(values
`(,_let loop ((expr expr))
(,_if (,_not (,_null? expr))
(,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)
(,_let ((expr (,_car expr)))
,match)
,@(map
(lambda (var)
`(,_set! ,(var->sym (push-var var))
(,_cons ,(var->sym var) ,(var->sym (push-var var)))))
vars)
(loop (,_cdr expr)))))
(map push-var vars)))))
(compile-match-vector
(lambda (pattern)
(let-values (((match vars) (compile-match-base (vector->list pattern))))
(values
`(,_if (,_vector? expr)
(,_let ((expr (,_vector->list expr)))
,match)
(exit #f))
vars)))))
(let-values (((match vars) (compile-match-base (cdr pattern))))
(values `(,_let ((expr (,_cdr expr)))
,match
#t)
vars))))
;;; compile expand
(define (compile-expand ellipsis reserved template)
(letrec ((compile-expand-base
(lambda (template ellipsis-valid)
(cond ((member template reserved eq?)
(values (var->sym template) (list template)))
((symbol? template)
(values `(rename ',template) '()))
((pair? template)
(compile-expand-list template ellipsis-valid))
((vector? template)
(compile-expand-vector template ellipsis-valid))
(else
(values `',template '())))))
(compile-expand-list
(lambda (template ellipsis-valid)
(let loop ((template template)
(expands '())
(vars '()))
(cond ;; (... hoge)
((and ellipsis-valid
(pair? template)
(compare (car template) ellipsis))
(if (and (pair? (cdr template)) (null? (cddr template)))
(compile-expand-base (cadr template) #f)
(values '(,_syntax-error "invalid template") '())))
;; hoge
((not (pair? template))
(let-values (((expand1 vars1)
(compile-expand-base template ellipsis-valid)))
(values
`(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
(append vars vars1))))
;; (a ... rest syms)
((and ellipsis-valid
(pair? (cdr template))
(compare (cadr template) ellipsis))
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cddr template)
(cons
`(,_unquote-splicing
(,_map (,_lambda ,(map var->sym vars1) ,expand1)
,@(map (lambda (v) (var->sym (push-var v))) vars1)))
expands)
(append vars (map push-var vars1)))))
(else
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cdr template)
(cons
`(,_unquote ,expand1)
expands)
(append vars vars1))))))))
(compile-expand-vector
(lambda (template ellipsis-valid)
(let-values (((expand1 vars1)
(compile-expand-base (vector->list template) ellipsis-valid)))
(values
`(,_list->vector ,expand1)
vars1)))))
(compile-expand-base template ellipsis)))
(define (check-vars vars-pattern vars-template)
;;fixme
#t)
(define (compile-rule ellipsis literals rule)
(let ((pattern (car rule))
(template (cadr rule)))
(let*-values (((match vars-match)
(compile-match ellipsis literals pattern))
((expand vars-expand)
(compile-expand ellipsis (flatten vars-match) template)))
(if (check-vars vars-match vars-expand)
(list vars-match match expand)
'mismatch))))
(define (expand-clauses clauses rename)
(cond ((null? clauses)
`(,_quote (syntax-error "no matching pattern")))
((compare (car clauses) 'mismatch)
`(,_syntax-error "invalid rule"))
(else
(let ((vars (list-ref (car clauses) 0))
(match (list-ref (car clauses) 1))
(expand (list-ref (car clauses) 2)))
`(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
(,_let ((result (,_call/cc (,_lambda (exit) ,match))))
(,_if result
,expand
,(expand-clauses (cdr clauses) rename))))))))
(define (normalize-form form)
(if (and (list? form) (>= (length form) 2))
(let ((ellipsis '...)
(literals (cadr form))
(rules (cddr form)))
(when (symbol? literals)
(set! ellipsis literals)
(set! literals (car rules))
(set! rules (cdr rules)))
(if (and (symbol? ellipsis)
(list? literals)
(every? symbol? literals)
(list? rules)
(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
(if (member ellipsis literals compare)
`(syntax-rules #f ,literals ,@rules)
`(syntax-rules ,ellipsis ,literals ,@rules))
#f))
#f))
(let ((form (normalize-form form)))
(if form
(let ((ellipsis (list-ref form 1))
(literals (list-ref form 2))
(rules (list-tail form 3)))
(let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
rules)))
`(,_er-macro-transformer
(,_lambda (expr rename cmp)
,(expand-clauses clauses r)))))
`(,_syntax-error "malformed syntax-rules"))))))
(export syntax-rules)
;; 4.2.4. Iteration
(export do)
;; 4.2.6. Dynamic bindings
@ -440,8 +67,8 @@
,@(map (lambda (var) `(parameter-pop! ,var)) vars)
result)))))))
(export parameterize make-parameter)
(export make-parameter
parameterize)
;; 4.2.7. Exception handling
@ -505,35 +132,80 @@
(export guard)
;; 5.5 Recored-type definitions
;; 4.2.8. Quasiquotation
(import (picrin record))
(export quasiquote
unquote
unquote-splicing)
;; 4.3.1. Binding constructs for syntactic keywords
(export let-syntax
letrec-syntax)
;; 4.3.2 Pattern language
(export syntax-rules)
;; 4.3.3. Signaling errors in macro transformers
(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
(export define-record-type)
(export (rename floor-remainder modulo)
(rename truncate-quotient quotient)
(rename truncate-remainder remainder))
(export define
lambda
if
quote
set!
begin
define-syntax)
;; 6.1. Equivalence predicates
(export eq?
eqv?
equal?)
(export boolean?
boolean=?
not)
;; 6.2. Numbers
(export char?
char->integer
integer->char)
(define (exact-integer? x)
(and (exact? x)
(integer? x)))
(define (zero? x)
(= x 0))
(define (positive? x)
(> x 0))
(define (negative? x)
(< x 0))
(define (min . args)
(let loop ((args args) (min +inf.0))
(if (null? args)
min
(loop (cdr args) (if (< (car args) min)
(car args)
min)))))
(define (max . args)
(let loop ((args args) (max -inf.0))
(if (null? args)
max
(loop (cdr args) (if (> (car args) max)
(car args)
max)))))
(define (square x)
(* x x))
(export number?
complex?
@ -551,8 +223,8 @@
zero?
positive?
negative?
odd?
even?
;; odd?
;; even?
min
max
+
@ -560,117 +232,29 @@
*
/
abs
floor-quotient
floor-remainder
;; floor-quotient
;; floor-remainder
floor/
truncate-quotient
truncate-remainder
;; truncate-quotient
;; truncate-remainder
truncate/
gcd
lcm
;; gcd
;; lcm
floor
ceiling
truncate
round
exact-integer-sqrt
;; exact-integer-sqrt
square
expt
number->string
string->number
finite?
infinite?
nan?
exp
log
sin
cos
tan
acos
asin
atan
sqrt)
string->number)
(export vector?
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
list->vector
vector->list)
;; 6.3. Booleans
(export string?
make-string
string-length
string-ref
string-set!
string=?
string<?
string>?
string<=?
string>=?
string-copy
string-copy!
string-append
string-fill!)
(export current-input-port
current-output-port
current-error-port
port?
input-port?
output-port?
textual-port?
binary-port?
close-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 with-exception-handler
raise
raise-continuable
error
error-object?
error-object-message
error-object-irritants
read-error?
file-error?)
(export procedure?
apply
map
for-each)
(export boolean?
boolean=?
not)
;; 6.4 Pairs and lists
@ -702,14 +286,14 @@
assv
assoc)
;; 6.5 Symbols
;; 6.5. Symbols
(export symbol?
symbol=?
symbol->string
string->symbol)
;; 6.6 Characters
;; 6.6. Characters
(define-macro (define-char-transitive-predicate name op)
`(define (,name . cs)
@ -721,56 +305,82 @@
(define-char-transitive-predicate char<=? <=)
(define-char-transitive-predicate char>=? >=)
(export char=?
(export char?
char->integer
integer->char
char=?
char<?
char>?
char<=?
char>=?)
;; 6.7 String
;; 6.7. Strings
(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 (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)
(let ((len (length list)))
(let ((v (make-string len)))
(do ((i 0 (+ i 1))
(l list (cdr l)))
((= i len)
v)
(string-set! v i (car l))))))
;; (define (list->string list)
;; (let ((len (length list)))
;; (let ((v (make-string len)))
;; (do ((i 0 (+ i 1))
;; (l list (cdr l)))
;; ((= i len)
;; v)
;; (string-set! v i (car l))))))
(define (string . objs)
(list->string objs))
;; (define (string . objs)
;; (list->string objs))
(export string
string->list
list->string
(rename string-copy substring))
;; (export string
;; string->list
;; list->string
;; (rename string-copy substring))
;; 6.8. Vector
(export string?
string-length
string-ref
string-copy
string-append
string=?
string<?
string>?
string<=?
string>=?)
;; 6.8. Vectors
(define (vector . objs)
(list->vector objs))
(define (vector->string . args)
(list->string (apply vector->list args)))
;; (define (vector->string . args)
;; (list->string (apply vector->list args)))
(define (string->vector . args)
(list->vector (apply string->list args)))
;; (define (string->vector . args)
;; (list->vector (apply string->list args)))
(export vector vector->string string->vector)
;; (export vector vector->string string->vector)
;; 6.9 bytevector
(export vector?
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
list->vector
vector->list)
;; 6.9. bytevector
(define (bytevector->list v start end)
(do ((i start (+ i 1))
@ -791,42 +401,72 @@
(define (bytevector . objs)
(list->bytevector objs))
(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 (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)))))
;; (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->list
list->bytevector
utf8->string
string->utf8)
;; (export bytevector
;; bytevector->list
;; list->bytevector
;; utf8->string
;; string->utf8)
;; 6.10 control features
(export bytevector?
make-bytevector
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
bytevector-copy!
bytevector-append)
(define (string-map f . strings)
(list->string (apply map f (map string->list strings))))
;; 6.10. Control features
(define (string-for-each f . strings)
(apply for-each f (map string->list strings)))
;; (define (string-map f . strings)
;; (list->string (apply map f (map string->list strings))))
(define (vector-map f . vectors)
(list->vector (apply map f (map vector->list vectors))))
;; (define (string-for-each f . strings)
;; (apply for-each f (map string->list strings)))
(define (vector-for-each f . vectors)
(apply for-each f (map vector->list vectors)))
;; (define (vector-map f . vectors)
;; (list->vector (apply map f (map vector->list vectors))))
(export string-map string-for-each
vector-map vector-for-each)
;; (define (vector-for-each f . vectors)
;; (apply for-each f (map vector->list vectors)))
;; (export string-map string-for-each
;; vector-map vector-for-each)
(export procedure?
apply
map
for-each
call-with-current-continuation
call/cc
dynamic-wind
values
call-with-values)
;; 6.11. Exceptions
(export with-exception-handler
raise
raise-continuable
error
error-object?
error-object-message
error-object-irritants
read-error?
file-error?)
;; 6.13. Input and output
@ -836,4 +476,47 @@
(lambda () (proc port))
(lambda () (close-port port))))
(export call-with-port))
(export current-input-port
current-output-port
current-error-port
call-with-port
port?
input-port?
output-port?
textual-port?
binary-port?
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))

16
piclib/scheme/eval.scm
View File

@ -1,15 +1,5 @@
(define-library (scheme eval)
(import (scheme base))
(define (null-environment n)
(if (not (= n 5))
(error "unsupported environment version" n)
'(scheme null)))
(define (scheme-report-environment n)
(if (not (= n 5))
(error "unsupported environment version" n)
'(scheme r5rs)))
(import (picrin base))
(define environment
(let ((counter 0))
@ -24,6 +14,4 @@
'(scheme base))
library-name))))
(export null-environment
scheme-report-environment
environment))
(export environment eval))

11
piclib/scheme/file.scm
View File

@ -1,5 +1,6 @@
(define-library (scheme file)
(import (scheme base))
(import (picrin base)
(scheme base))
(define (call-with-input-file filename callback)
(call-with-port (open-input-file filename) callback))
@ -19,7 +20,13 @@
(parameterize ((current-output-port port))
(thunk)))))
(export call-with-input-file
(export open-input-file
open-binary-input-file
open-output-file
open-binary-output-file
delete-file
file-exists?
call-with-input-file
call-with-output-file
with-input-from-file
with-output-to-file))

29
src/eval.c
View File

@ -1,29 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/macro.h"
static pic_value
pic_eval_eval(pic_state *pic)
{
pic_value program, spec;
struct pic_lib *lib;
pic_get_args(pic, "oo", &program, &spec);
lib = pic_find_library(pic, spec);
if (lib == NULL) {
pic_errorf(pic, "no library found: ~s", spec);
}
return pic_eval(pic, program, lib);
}
void
pic_init_eval(pic_state *pic)
{
pic_deflibrary (pic, "(scheme eval)") {
pic_defun(pic, "eval", pic_eval_eval);
}
}

119
src/file.c
View File

@ -1,119 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/port.h"
#include "picrin/error.h"
static noreturn void
file_error(pic_state *pic, const char *msg)
{
pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value());
}
static pic_value
generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
{
struct pic_port *port;
xFILE *file;
file = xfopen(fname, mode);
if (! file) {
file_error(pic, "could not open file");
}
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
port->file = file;
port->flags = flags;
port->status = PIC_PORT_OPEN;
return pic_obj_value(port);
}
pic_value
pic_file_open_input_file(pic_state *pic)
{
static const short flags = PIC_PORT_IN | PIC_PORT_TEXT;
char *fname;
pic_get_args(pic, "z", &fname);
return generic_open_file(pic, fname, "r", flags);
}
pic_value
pic_file_open_input_binary_file(pic_state *pic)
{
static const short flags = PIC_PORT_IN | PIC_PORT_BINARY;
char *fname;
pic_get_args(pic, "z", &fname);
return generic_open_file(pic, fname, "rb", flags);
}
pic_value
pic_file_open_output_file(pic_state *pic)
{
static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT;
char *fname;
pic_get_args(pic, "z", &fname);
return generic_open_file(pic, fname, "w", flags);
}
pic_value
pic_file_open_output_binary_file(pic_state *pic)
{
static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY;
char *fname;
pic_get_args(pic, "z", &fname);
return generic_open_file(pic, fname, "wb", flags);
}
pic_value
pic_file_exists_p(pic_state *pic)
{
char *fname;
FILE *fp;
pic_get_args(pic, "z", &fname);
fp = fopen(fname, "r");
if (fp) {
fclose(fp);
return pic_true_value();
} else {
return pic_false_value();
}
}
pic_value
pic_file_delete(pic_state *pic)
{
char *fname;
pic_get_args(pic, "z", &fname);
if (remove(fname) != 0) {
file_error(pic, "file cannot be deleted");
}
return pic_none_value();
}
void
pic_init_file(pic_state *pic)
{
pic_deflibrary (pic, "(scheme file)") {
pic_defun(pic, "open-input-file", pic_file_open_input_file);
pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file);
pic_defun(pic, "open-output-file", pic_file_open_output_file);
pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file);
pic_defun(pic, "file-exists?", pic_file_exists_p);
pic_defun(pic, "delete-file", pic_file_delete);
}
}

70
src/init.c
View File

@ -1,70 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdlib.h>
#include "picrin.h"
#include "picrin/pair.h"
static pic_value
pic_features(pic_state *pic)
{
pic_value features = pic_nil_value();
pic_get_args(pic, "");
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features);
return features;
}
static pic_value
pic_libraries(pic_state *pic)
{
pic_value libs = pic_nil_value(), lib;
pic_get_args(pic, "");
pic_for_each (lib, pic->libs) {
libs = pic_cons(pic, pic_car(pic, lib), libs);
}
return libs;
}
void pic_init_eval(pic_state *);
void pic_init_file(pic_state *);
void pic_init_load(pic_state *);
void pic_init_macro2(pic_state *);
void pic_init_system(pic_state *);
void pic_init_time(pic_state *);
void pic_init_contrib(pic_state *);
void pic_load_piclib(pic_state *);
void
pic_init_picrin(pic_state *pic)
{
pic_deflibrary (pic, "(picrin library)") {
pic_defun(pic, "libraries", pic_libraries);
}
pic_deflibrary (pic, "(scheme base)") {
pic_defun(pic, "features", pic_features);
pic_init_eval(pic);
pic_init_file(pic);
pic_init_load(pic);
pic_init_macro2(pic);
pic_init_system(pic);
pic_init_time(pic);
pic_init_contrib(pic);
pic_load_piclib(pic);
}
}

79
src/load.c
View File

@ -1,79 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/port.h"
#include "picrin/error.h"
void
pic_load_port(pic_state *pic, struct pic_port *port)
{
pic_value form;
pic_try {
size_t ai = pic_gc_arena_preserve(pic);
while (! pic_eof_p(form = pic_read(pic, port))) {
pic_eval(pic, form, pic->lib);
pic_gc_arena_restore(pic, ai);
}
}
pic_catch {
pic_errorf(pic, "load error: %s", pic_errmsg(pic));
}
}
void
pic_load_cstr(pic_state *pic, const char *src)
{
struct pic_port *port = pic_open_input_string(pic, src);
pic_load_port(pic, port);
pic_close_port(pic, port);
}
void
pic_load(pic_state *pic, const char *filename)
{
struct pic_port *port;
xFILE *file;
file = xfopen(filename, "r");
if (file == NULL) {
pic_errorf(pic, "could not open file: %s", filename);
}
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
port->file = file;
port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
pic_load_port(pic, port);
pic_close_port(pic, port);
}
static pic_value
pic_load_load(pic_state *pic)
{
pic_value envid;
char *fn;
pic_get_args(pic, "z|o", &fn, &envid);
pic_load(pic, fn);
return pic_none_value();
}
void
pic_init_load(pic_state *pic)
{
pic_deflibrary (pic, "(scheme load)") {
pic_defun(pic, "load", pic_load_load);
}
}

47
src/macro.c
View File

@ -1,47 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
static pic_value
pic_macro_gensym(pic_state *pic)
{
static const char skel[] = ".g";
pic_sym uniq;
pic_get_args(pic, "");
uniq = pic_gensym(pic, pic_intern_cstr(pic, skel));
return pic_sym_value(uniq);
}
static pic_value
pic_macro_ungensym(pic_state *pic)
{
pic_sym sym;
pic_get_args(pic, "m", &sym);
return pic_sym_value(pic_ungensym(pic, sym));
}
static pic_value
pic_macro_macroexpand(pic_state *pic)
{
pic_value expr;
pic_get_args(pic, "o", &expr);
return pic_macroexpand(pic, expr, pic->lib);
}
void
pic_init_macro2(pic_state *pic)
{
pic_deflibrary (pic, "(picrin macro)") {
pic_defun(pic, "gensym", pic_macro_gensym);
pic_defun(pic, "ungensym", pic_macro_ungensym);
pic_defun(pic, "macroexpand", pic_macro_macroexpand);
}
}

47
src/main.c
View File

@ -3,8 +3,55 @@
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/error.h"
static pic_value
pic_features(pic_state *pic)
{
pic_value features = pic_nil_value();
pic_get_args(pic, "");
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features);
return features;
}
static pic_value
pic_libraries(pic_state *pic)
{
pic_value libs = pic_nil_value(), lib;
pic_get_args(pic, "");
pic_for_each (lib, pic->libs) {
libs = pic_cons(pic, pic_car(pic, lib), libs);
}
return libs;
}
void pic_init_contrib(pic_state *);
void pic_load_piclib(pic_state *);
void
pic_init_picrin(pic_state *pic)
{
pic_deflibrary (pic, "(picrin library)") {
pic_defun(pic, "libraries", pic_libraries);
}
pic_deflibrary (pic, "(scheme base)") {
pic_defun(pic, "features", pic_features);
pic_init_contrib(pic);
pic_load_piclib(pic);
}
}
int
main(int argc, char *argv[], char **envp)
{

136
src/system.c
View File

@ -1,136 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdlib.h>
#include "picrin.h"
#include "picrin/string.h"
#include "picrin/pair.h"
#include "picrin/cont.h"
static pic_value
pic_system_cmdline(pic_state *pic)
{
pic_value v = pic_nil_value();
int i;
pic_get_args(pic, "");
for (i = 0; i < pic->argc; ++i) {
size_t ai = pic_gc_arena_preserve(pic);
v = pic_cons(pic, pic_obj_value(pic_str_new_cstr(pic, pic->argv[i])), v);
pic_gc_arena_restore(pic, ai);
}
return pic_reverse(pic, v);
}
static pic_value
pic_system_exit(pic_state *pic)
{
pic_value v;
int argc, status = EXIT_SUCCESS;
argc = pic_get_args(pic, "|o", &v);
if (argc == 1) {
switch (pic_type(v)) {
case PIC_TT_FLOAT:
status = (int)pic_float(v);
break;
case PIC_TT_INT:
status = pic_int(v);
break;
default:
break;
}
}
pic_close(pic);
exit(status);
}
static pic_value
pic_system_emergency_exit(pic_state *pic)
{
pic_value v;
int argc, status = EXIT_FAILURE;
argc = pic_get_args(pic, "|o", &v);
if (argc == 1) {
switch (pic_type(v)) {
case PIC_TT_FLOAT:
status = (int)pic_float(v);
break;
case PIC_TT_INT:
status = pic_int(v);
break;
default:
break;
}
}
_Exit(status);
}
static pic_value
pic_system_getenv(pic_state *pic)
{
char *str, *val;
pic_get_args(pic, "z", &str);
val = getenv(str);
if (val == NULL)
return pic_nil_value();
else
return pic_obj_value(pic_str_new_cstr(pic, val));
}
static pic_value
pic_system_getenvs(pic_state *pic)
{
char **envp;
pic_value data = pic_nil_value();
size_t ai = pic_gc_arena_preserve(pic);
pic_get_args(pic, "");
if (! pic->envp) {
return pic_nil_value();
}
for (envp = pic->envp; *envp; ++envp) {
pic_str *key, *val;
int i;
for (i = 0; (*envp)[i] != '='; ++i)
;
key = pic_str_new(pic, *envp, i);
val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key)));
/* push */
data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, data);
}
return data;
}
void
pic_init_system(pic_state *pic)
{
pic_deflibrary (pic, "(scheme process-context)") {
pic_defun(pic, "command-line", pic_system_cmdline);
pic_defun(pic, "exit", pic_system_exit);
pic_defun(pic, "emergency-exit", pic_system_emergency_exit);
pic_defun(pic, "get-environment-variable", pic_system_getenv);
pic_defun(pic, "get-environment-variables", pic_system_getenvs);
}
}

49
src/time.c
View File

@ -1,49 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <time.h>
#include "picrin.h"
#define UTC_TAI_DIFF 35
static pic_value
pic_current_second(pic_state *pic)
{
time_t t;
pic_get_args(pic, "");
time(&t);
return pic_float_value((double)t + UTC_TAI_DIFF);
}
static pic_value
pic_current_jiffy(pic_state *pic)
{
clock_t c;
pic_get_args(pic, "");
c = clock();
return pic_int_value(c);
}
static pic_value
pic_jiffies_per_second(pic_state *pic)
{
pic_get_args(pic, "");
return pic_int_value(CLOCKS_PER_SEC);
}
void
pic_init_time(pic_state *pic)
{
pic_deflibrary (pic, "(scheme time)") {
pic_defun(pic, "current-second", pic_current_second);
pic_defun(pic, "current-jiffy", pic_current_jiffy);
pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second);
}
}