WIP
This commit is contained in:
parent
c3ef97992d
commit
3919c17fdc
|
@ -1 +1 @@
|
||||||
Subproject commit b8b5743589ccbed555805d768d5c840aad350499
|
Subproject commit a2848f3eafdbe3a4579dd4c8054ab7e3b62e6812
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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,8 +94,7 @@
|
||||||
(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)
|
||||||
|
@ -99,7 +102,9 @@
|
||||||
(write obj port))
|
(write obj port))
|
||||||
array)
|
array)
|
||||||
(display ")" port)
|
(display ")" port)
|
||||||
(get-output-string port))))
|
(let ((str (get-output-string port)))
|
||||||
|
(close-port port)
|
||||||
|
str)))
|
||||||
|
|
||||||
(export make-array
|
(export make-array
|
||||||
array
|
array
|
||||||
|
|
|
@ -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))
|
|
||||||
|
|
|
@ -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 '()))
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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))
|
|
@ -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 ()
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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))
|
|
||||||
|
|
|
@ -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
29
src/eval.c
|
@ -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
119
src/file.c
|
@ -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
70
src/init.c
|
@ -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
79
src/load.c
|
@ -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
47
src/macro.c
|
@ -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
47
src/main.c
|
@ -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
136
src/system.c
|
@ -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
49
src/time.c
|
@ -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);
|
|
||||||
}
|
|
||||||
}
|
|
Loading…
Reference in New Issue