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 list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.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/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/cxr.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/read.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/case-lambda.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/eval.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/r5rs.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm

31
piclib/picrin/array.scm
View File

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

580
piclib/picrin/base.scm
View File

@ -1,4 +1,307 @@
(define-library (picrin base) (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 (export define
lambda lambda
if if
@ -7,6 +310,16 @@
begin begin
define-syntax) 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? (export eq?
eqv? eqv?
equal?) equal?)
@ -146,8 +459,13 @@
output-port? output-port?
textual-port? textual-port?
binary-port? binary-port?
close-port close-port
open-input-file
open-output-file
open-binary-input-file
open-binary-output-file
open-input-string open-input-string
open-output-string open-output-string
get-output-string get-output-string
@ -188,6 +506,7 @@
make-identifier) make-identifier)
(export call-with-current-continuation (export call-with-current-continuation
call/cc
continue continue
dynamic-wind dynamic-wind
values values
@ -216,255 +535,18 @@
write-shared write-shared
display) display)
(define-syntax syntax-error (export command-line
(er-macro-transformer exit
(lambda (expr rename compare) emergency-exit
(apply error (cdr expr))))) file-exists?
delete-file
get-environment-variable
get-environment-variables)
(define-syntax define-auxiliary-syntax (export current-second
(er-macro-transformer current-jiffy
(lambda (expr r c) jiffies-per-second)
(list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_
(list (r 'error) "invalid use of auxiliary syntax"))))))
(define-auxiliary-syntax else) (export eval)
(define-auxiliary-syntax =>)
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define-auxiliary-syntax unquote)
(define-auxiliary-syntax unquote-splicing)
(define-syntax let (export load))
(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))

3
piclib/picrin/dictionary.scm
View File

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

8
piclib/picrin/macro.scm
View File

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

19
piclib/picrin/record.scm
View File

@ -1,6 +1,6 @@
(define-library (picrin record) (define-library (picrin record)
(import (picrin base) (import (picrin base)
(scheme base)) (picrin macro))
;; define-record-writer ;; define-record-writer
@ -8,14 +8,15 @@
(record-set! record-type 'writer writer)) (record-set! record-type 'writer writer))
(define-syntax define-record-writer (define-syntax define-record-writer
(syntax-rules () (er-macro-transformer
((_ (type obj) body ...) (lambda (form r compare)
(set-record-writer! type (let ((formal (cadr form)))
(lambda (obj) (if (pair? formal)
body ...))) `(,(r 'set-record-writer!) ,(car formal)
((_ type writer) (,(r 'lambda) (,(cadr formal))
(set-record-writer! type ,@(cddr form)))
writer)))) `(,(r 'set-record-writer!) ,formal
,@(cddr form)))))))
;; define-record-type ;; 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) (define-library (picrin test)
(import (scheme base) (import (picrin base)
(scheme process-context) (picrin syntax-rules))
(picrin base))
(define test-counter 0) (define test-counter 0)
(define counter 0) (define counter 0)
@ -77,7 +76,7 @@
(length fails)) (length fails))
(define (test-exit) (define (test-exit)
(exit (zero? (test-failure-count)))) (exit (= (test-failure-count) 0)))
(define-syntax test-syntax-error (define-syntax test-syntax-error
(syntax-rules () (syntax-rules ()

867
piclib/scheme/base.scm
View File

@ -1,429 +1,56 @@
(define-library (scheme base) (define-library (scheme base)
(import (picrin base) (import (picrin base)
(picrin macro)) (picrin macro)
(picrin record)
(picrin syntax-rules))
(export define (export else => _ ...)
set!
lambda
quote
if
begin
define-syntax)
;; core syntax ;; 4.1.2. Literal expressions
(import (scheme file)) (export quote)
(define-syntax include ;; 4.1.4. Procedures
(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 let let* letrec letrec* (export lambda)
quasiquote unquote unquote-splicing
and or
cond case else =>
do when unless
let-syntax letrec-syntax
include
_ ... syntax-error)
;; 4.1.5. Conditionals
;; utility functions (export if)
(define (walk proc expr) ;; 4.1.6. Assignments
(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) (export set!)
(let ((list '()))
(walk
(lambda (x)
(set! list (cons x list)))
expr)
(reverse list)))
(define (reverse* l) ;; 4.1.7. Inclusion
;; (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) (export include)
(if (null? l)
#t
(and (pred (car l)) (every? pred (cdr l)))))
;; 4.2.1. Conditionals
;; extra syntax (export cond
case
and
or
when
unless)
(define-syntax let*-values ;; 4.2.2. Binding constructs
(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 (export let
(er-macro-transformer let*
(lambda (form r c) letrec
`(,(r 'let*-values) ,@(cdr form))))) letrec*
let-values
let*-values)
(define uniq ;; 4.2.3. Sequencing
(let ((counter 0))
(lambda (x)
(let ((sym (string->symbol (string-append "var$" (number->string counter)))))
(set! counter (+ counter 1))
sym))))
(define-syntax define-values (export begin)
(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 let-values ;; 4.2.4. Iteration
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)
(export do)
;; 4.2.6. Dynamic bindings ;; 4.2.6. Dynamic bindings
@ -440,8 +67,8 @@
,@(map (lambda (var) `(parameter-pop! ,var)) vars) ,@(map (lambda (var) `(parameter-pop! ,var)) vars)
result))))))) result)))))))
(export parameterize make-parameter) (export make-parameter
parameterize)
;; 4.2.7. Exception handling ;; 4.2.7. Exception handling
@ -505,35 +132,80 @@
(export guard) (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 define-record-type)
(export (rename floor-remainder modulo) ;; 6.1. Equivalence predicates
(rename truncate-quotient quotient)
(rename truncate-remainder remainder))
(export define
lambda
if
quote
set!
begin
define-syntax)
(export eq? (export eq?
eqv? eqv?
equal?) equal?)
(export boolean? ;; 6.2. Numbers
boolean=?
not)
(export char? (define (exact-integer? x)
char->integer (and (exact? x)
integer->char) (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? (export number?
complex? complex?
@ -551,8 +223,8 @@
zero? zero?
positive? positive?
negative? negative?
odd? ;; odd?
even? ;; even?
min min
max max
+ +
@ -560,117 +232,29 @@
* *
/ /
abs abs
floor-quotient ;; floor-quotient
floor-remainder ;; floor-remainder
floor/ floor/
truncate-quotient ;; truncate-quotient
truncate-remainder ;; truncate-remainder
truncate/ truncate/
gcd ;; gcd
lcm ;; lcm
floor floor
ceiling ceiling
truncate truncate
round round
exact-integer-sqrt ;; exact-integer-sqrt
square square
expt expt
number->string number->string
string->number string->number)
finite?
infinite?
nan?
exp
log
sin
cos
tan
acos
asin
atan
sqrt)
(export vector? ;; 6.3. Booleans
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
list->vector
vector->list)
(export string? (export boolean?
make-string boolean=?
string-length not)
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)
;; 6.4 Pairs and lists ;; 6.4 Pairs and lists
@ -702,14 +286,14 @@
assv assv
assoc) assoc)
;; 6.5 Symbols ;; 6.5. Symbols
(export symbol? (export symbol?
symbol=? symbol=?
symbol->string symbol->string
string->symbol) string->symbol)
;; 6.6 Characters ;; 6.6. Characters
(define-macro (define-char-transitive-predicate name op) (define-macro (define-char-transitive-predicate name op)
`(define (,name . cs) `(define (,name . cs)
@ -721,56 +305,82 @@
(define-char-transitive-predicate char<=? <=) (define-char-transitive-predicate char<=? <=)
(define-char-transitive-predicate char>=? >=) (define-char-transitive-predicate char>=? >=)
(export char=? (export char?
char->integer
integer->char
char=?
char<? char<?
char>? char>?
char<=? char<=?
char>=?) char>=?)
;; 6.7 String ;; 6.7. Strings
(define (string->list string . opts) ;; (define (string->list string . opts)
(let ((start (if (pair? opts) (car opts) 0)) ;; (let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2) ;; (end (if (>= (length opts) 2)
(cadr opts) ;; (cadr opts)
(string-length string)))) ;; (string-length string))))
(do ((i start (+ i 1)) ;; (do ((i start (+ i 1))
(res '())) ;; (res '()))
((= i end) ;; ((= i end)
(reverse res)) ;; (reverse res))
(set! res (cons (string-ref string i) res))))) ;; (set! res (cons (string-ref string i) res)))))
(define (list->string list) ;; (define (list->string list)
(let ((len (length list))) ;; (let ((len (length list)))
(let ((v (make-string len))) ;; (let ((v (make-string len)))
(do ((i 0 (+ i 1)) ;; (do ((i 0 (+ i 1))
(l list (cdr l))) ;; (l list (cdr l)))
((= i len) ;; ((= i len)
v) ;; v)
(string-set! v i (car l)))))) ;; (string-set! v i (car l))))))
(define (string . objs) ;; (define (string . objs)
(list->string objs)) ;; (list->string objs))
(export string ;; (export string
string->list ;; string->list
list->string ;; list->string
(rename string-copy substring)) ;; (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) (define (vector . objs)
(list->vector objs)) (list->vector objs))
(define (vector->string . args) ;; (define (vector->string . args)
(list->string (apply vector->list args))) ;; (list->string (apply vector->list args)))
(define (string->vector . args) ;; (define (string->vector . args)
(list->vector (apply string->list 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) (define (bytevector->list v start end)
(do ((i start (+ i 1)) (do ((i start (+ i 1))
@ -791,42 +401,72 @@
(define (bytevector . objs) (define (bytevector . objs)
(list->bytevector objs)) (list->bytevector objs))
(define (utf8->string v . opts) ;; (define (utf8->string v . opts)
(let ((start (if (pair? opts) (car opts) 0)) ;; (let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2) ;; (end (if (>= (length opts) 2)
(cadr opts) ;; (cadr opts)
(bytevector-length v)))) ;; (bytevector-length v))))
(list->string (map integer->char (bytevector->list v start end))))) ;; (list->string (map integer->char (bytevector->list v start end)))))
(define (string->utf8 s . opts) ;; (define (string->utf8 s . opts)
(let ((start (if (pair? opts) (car opts) 0)) ;; (let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2) ;; (end (if (>= (length opts) 2)
(cadr opts) ;; (cadr opts)
(string-length s)))) ;; (string-length s))))
(list->bytevector (map char->integer (string->list s start end))))) ;; (list->bytevector (map char->integer (string->list s start end)))))
(export bytevector ;; (export bytevector
bytevector->list ;; bytevector->list
list->bytevector ;; list->bytevector
utf8->string ;; utf8->string
string->utf8) ;; 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) ;; 6.10. Control features
(list->string (apply map f (map string->list strings))))
(define (string-for-each f . strings) ;; (define (string-map f . strings)
(apply for-each f (map string->list strings))) ;; (list->string (apply map f (map string->list strings))))
(define (vector-map f . vectors) ;; (define (string-for-each f . strings)
(list->vector (apply map f (map vector->list vectors)))) ;; (apply for-each f (map string->list strings)))
(define (vector-for-each f . vectors) ;; (define (vector-map f . vectors)
(apply for-each f (map vector->list vectors))) ;; (list->vector (apply map f (map vector->list vectors))))
(export string-map string-for-each ;; (define (vector-for-each f . vectors)
vector-map vector-for-each) ;; (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 ;; 6.13. Input and output
@ -836,4 +476,47 @@
(lambda () (proc port)) (lambda () (proc port))
(lambda () (close-port 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) (define-library (scheme eval)
(import (scheme base)) (import (picrin 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)))
(define environment (define environment
(let ((counter 0)) (let ((counter 0))
@ -24,6 +14,4 @@
'(scheme base)) '(scheme base))
library-name)))) library-name))))
(export null-environment (export environment eval))
scheme-report-environment
environment))

11
piclib/scheme/file.scm
View File

@ -1,5 +1,6 @@
(define-library (scheme file) (define-library (scheme file)
(import (scheme base)) (import (picrin base)
(scheme base))
(define (call-with-input-file filename callback) (define (call-with-input-file filename callback)
(call-with-port (open-input-file filename) callback)) (call-with-port (open-input-file filename) callback))
@ -19,7 +20,13 @@
(parameterize ((current-output-port port)) (parameterize ((current-output-port port))
(thunk))))) (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 call-with-output-file
with-input-from-file with-input-from-file
with-output-to-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.h"
#include "picrin/pair.h"
#include "picrin/error.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 int
main(int argc, char *argv[], char **envp) 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);
}
}