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

Merge branch 'piclib-to-contrib'

This commit is contained in:
Yuichi Nishiwaki 2015-07-09 04:16:31 +09:00
parent c99596d086 8cc6307eaa
commit 881bfa807d
21 changed files with 414 additions and 770 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Makefile
View File

@ -7,15 +7,6 @@ PICRIN_SRCS = \
src/init_contrib.c
PICRIN_OBJS = \
$(PICRIN_SRCS:.c=.o)
PICRIN_LIBS = \
piclib/picrin/base.scm\
piclib/picrin/macro.scm\
piclib/picrin/record.scm\
piclib/picrin/array.scm\
piclib/picrin/control.scm\
piclib/picrin/experimental/lambda.scm\
piclib/picrin/syntax-rules.scm\
piclib/picrin/test.scm
CONTRIB_SRCS =
CONTRIB_OBJS = $(CONTRIB_SRCS:.c=.o)
@ -40,8 +31,8 @@ debug: bin/picrin
bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a
$(CC) $(CFLAGS) -o $@ $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a $(LDFLAGS)
src/load_piclib.c: $(PICRIN_LIBS) $(CONTRIB_LIBS)
perl etc/mkloader.pl $(PICRIN_LIBS) $(CONTRIB_LIBS) > $@
src/load_piclib.c: $(CONTRIB_LIBS)
perl etc/mkloader.pl $(CONTRIB_LIBS) > $@
src/init_contrib.c:
perl etc/mkinit.pl $(CONTRIB_INITS) > $@

0
piclib/picrin/macro.scm → contrib/10.macro/macro.scm
View File

6
contrib/10.macro/nitro.mk Normal file
View File

@ -0,0 +1,6 @@
CONTRIB_LIBS += $(wildcard contrib/10.macro/*.scm)
CONTRIB_TESTS += test-macro
test-macro: bin/picrin
bin/picrin contrib/10.macro/t/ir-macro.scm

0
t/ir-macro.scm → contrib/10.macro/t/ir-macro.scm
View File

394
contrib/20.r7rs/scheme/base.scm
View File

@ -1,8 +1,6 @@
(define-library (scheme base)
(import (picrin base)
(picrin macro)
(picrin record)
(picrin syntax-rules)
(picrin string)
(scheme file))
@ -76,63 +74,57 @@
;; 4.2.7. Exception handling
(define-syntax guard-aux
(syntax-rules (else =>)
((guard-aux reraise (else result1 result2 ...))
(begin result1 result2 ...))
((guard-aux reraise (test => result))
(let ((temp test))
(if temp
(result temp)
reraise)))
((guard-aux reraise (test => result)
clause1 clause2 ...)
(let ((temp test))
(if temp
(result temp)
(guard-aux reraise clause1 clause2 ...))))
((guard-aux reraise (test))
(or test reraise))
((guard-aux reraise (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(guard-aux reraise clause1 clause2 ...))))
((guard-aux reraise (test result1 result2 ...))
(if test
(begin result1 result2 ...)
reraise))
((guard-aux reraise
(test result1 result2 ...)
clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...)))))
(define-syntax (guard-aux reraise . clauses)
(letrec
((else?
(lambda (clause)
(and (list? clause) (equal? #'else (car clause)))))
(=>?
(lambda (clause)
(and (list? clause) (= (length clause) 3) (equal? #'=> (list-ref clause 1))))))
(if (null? clauses)
reraise
(let ((clause (car clauses))
(rest (cdr clauses)))
(cond
((else? clause)
#`(begin #,@(cdr clause)))
((=>? clause)
#`(let ((tmp #,(list-ref clause 0)))
(if tmp
(#,(list-ref clause 2) tmp)
(guard-aux #,reraise #,@rest))))
((= (length clause) 1)
#`(or #,(car clause) (guard-aux #,reraise #,@rest)))
(else
#`(if #,(car clause)
(begin #,@(cdr clause))
(guard-aux #,reraise #,@rest))))))))
(define-syntax guard
(syntax-rules ()
((guard (var clause ...) e1 e2 ...)
((call/cc
(lambda (guard-k)
(with-exception-handler
(lambda (condition)
((call/cc
(lambda (handler-k)
(guard-k
(lambda ()
(let ((var condition))
(guard-aux
(handler-k
(lambda ()
(raise-continuable condition)))
clause ...))))))))
(lambda ()
(call-with-values
(lambda () e1 e2 ...)
(lambda args
(guard-k
(lambda ()
(apply values args)))))))))))))
(define-syntax (guard formal . body)
(let ((var (car formal))
(clauses (cdr formal)))
#`((call/cc
(lambda (guard-k)
(with-exception-handler
(lambda (condition)
((call/cc
(lambda (handler-k)
(guard-k
(lambda ()
(let ((#,var condition))
(guard-aux
(handler-k
(lambda ()
(raise-continuable condition)))
#,@clauses))))))))
(lambda ()
(call-with-values
(lambda () #,@body)
(lambda args
(guard-k
(lambda ()
(apply values args))))))))))))
(export guard)
@ -149,6 +141,242 @@
;; 4.3.2 Pattern language
(define (succ n)
(+ n 1))
(define (pred n)
(if (= n 0)
0
(- n 1)))
(define (every? args)
(if (null? args)
#t
(if (car args)
(every? (cdr args))
#f)))
(define (filter f list)
(if (null? list)
'()
(if (f (car list))
(cons (car list)
(filter f (cdr list)))
(filter f (cdr list)))))
(define (take-tail n list)
(let drop ((n (- (length list) n)) (list list))
(if (= n 0)
list
(drop (- n 1) (cdr list)))))
(define (drop-tail n list)
(let take ((n (- (length list) n)) (list list))
(if (= n 0)
'()
(cons (car list) (take (- n 1) (cdr list))))))
(define (map-keys f assoc)
(map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
(define (map-values f assoc)
(map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
;; TODO
;; - placeholder
;; - vector
;; - (... template) pattern
;; p ::= constant
;; | var
;; | (p ... . p) (in input pattern, tail p should be a proper list)
;; | (p . p)
(define (compile ellipsis literals rules)
(define (constant? obj)
(and (not (pair? obj))
(not (variable? obj))))
(define (literal? obj)
(and (variable? obj)
(memq obj literals)))
(define (many? pat)
(and (pair? pat)
(pair? (cdr pat))
(variable? (cadr pat))
(variable=? (cadr pat) ellipsis)))
(define (pattern-validator pat) ; pattern -> validator
(letrec
((pattern-validator
(lambda (pat form)
(cond
((constant? pat)
#`(equal? '#,pat #,form))
((literal? pat)
#`(and (variable? #,form) (variable=? #'#,pat #,form)))
((variable? pat)
#t)
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
#`(and (list? #,form)
(>= (length #,form) #,(length (cddr pat)))
(every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head))
#,(pattern-validator (cddr pat) tail))))
((pair? pat)
#`(and (pair? #,form)
#,(pattern-validator (car pat) #`(car #,form))
#,(pattern-validator (cdr pat) #`(cdr #,form))))
(else
#f)))))
(pattern-validator pat 'it)))
(define (pattern-variables pat) ; pattern -> (freevar)
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`(,pat))
((many? pat)
(append (pattern-variables (car pat))
(pattern-variables (cddr pat))))
((pair? pat)
(append (pattern-variables (car pat))
(pattern-variables (cdr pat))))))
(define (pattern-levels pat) ; pattern -> ((var * int))
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`((,pat . 0)))
((many? pat)
(append (map-values succ (pattern-levels (car pat)))
(pattern-levels (cddr pat))))
((pair? pat)
(append (pattern-levels (car pat))
(pattern-levels (cdr pat))))))
(define (pattern-selectors pat) ; pattern -> ((var * selector))
(letrec
((pattern-selectors
(lambda (pat form)
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`((,pat . ,form)))
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
(let ((envs (pattern-selectors (car pat) 'it)))
(append
(map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs)
(pattern-selectors (cddr pat) tail)))))
((pair? pat)
(append (pattern-selectors (car pat) #`(car #,form))
(pattern-selectors (cdr pat) #`(cdr #,form))))))))
(pattern-selectors pat 'it)))
(define (template-representation pat levels selectors)
(cond
((constant? pat)
pat)
((variable? pat)
(let ((it (assq pat levels)))
(if it
(if (= 0 (cdr it))
(cdr (assq pat selectors))
(error "unmatched pattern variable level" pat))
#`(#,'rename '#,pat))))
((many? pat)
(letrec*
((inner-pat
(car pat))
(inner-levels
(map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels))
(inner-freevars
(filter (lambda (v) (assq v levels)) (pattern-variables inner-pat)))
(inner-vars
;; select only vars declared with ellipsis
(filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars))
(inner-tmps
(map (lambda (v) #'it) inner-vars))
(inner-selectors
;; first env '(map cons ...)' shadows second env 'selectors'
(append (map cons inner-vars inner-tmps) selectors))
(inner-rep
(template-representation inner-pat inner-levels inner-selectors))
(sorted-selectors
(map (lambda (v) (assq v selectors)) inner-vars))
(list-of-selectors
;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs)
(map cdr sorted-selectors)))
(let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors))
(rep2 (template-representation (cddr pat) levels selectors)))
#`(append #,rep1 #,rep2))))
((pair? pat)
#`(cons #,(template-representation (car pat) levels selectors)
#,(template-representation (cdr pat) levels selectors)))))
(define (compile-rule pattern template)
(let ((levels
(pattern-levels pattern))
(selectors
(pattern-selectors pattern)))
(template-representation template levels selectors)))
(define (compile-rules rules)
(if (null? rules)
#`(error "unmatch")
(let ((pattern (car (car rules)))
(template (cadr (car rules))))
#`(if #,(pattern-validator pattern)
#,(compile-rule pattern template)
#,(compile-rules (cdr rules))))))
(define (compile rules)
#`(call-with-current-environment
(lambda (env)
(letrec
((#,'rename (let ((reg (make-register)))
(lambda (x)
(if (undefined? (reg x))
(let ((id (make-identifier x env)))
(reg x id)
id)
(reg x))))))
(lambda #,'it
#,(compile-rules rules))))))
(let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
(compile rules)))
(define-syntax (syntax-rules . args)
(if (list? (car args))
#`(syntax-rules ... #,@args)
(let ((ellipsis (car args))
(literals (car (cdr args)))
(rules (cdr (cdr args))))
(compile ellipsis literals rules))))
(define-syntax (define-auxiliary-syntax var)
#`(define-macro #,var
(lambda _
(error "invalid use of auxiliary syntax" '#,var))))
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(export syntax-rules
_
...)
@ -171,6 +399,56 @@
;; 5.5 Recored-type definitions
(define ((boot-make-record-type <meta-type>) name)
(let ((rectype (make-record <meta-type>)))
(record-set! rectype 'name name)
rectype))
(define <record-type>
(let ((<record-type> ((boot-make-record-type #t) 'record-type)))
(record-set! <record-type> '@@type <record-type>)
<record-type>))
(define make-record-type (boot-make-record-type <record-type>))
(define-syntax (define-record-constructor type name . fields)
(let ((record #'record))
#`(define (#,name . #,fields)
(let ((#,record (make-record #,type)))
#,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
#,record))))
(define-syntax (define-record-predicate type name)
#`(define (#,name obj)
(and (record? obj)
(eq? (record-type obj) #,type))))
(define-syntax (define-record-accessor pred field accessor)
#`(define (#,accessor record)
(if (#,pred record)
(record-ref record '#,field)
(error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(define-syntax (define-record-modifier pred field modifier)
#`(define (#,modifier record val)
(if (#,pred record)
(record-set! record '#,field val)
(error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
(define-syntax (define-record-field pred field accessor . modifier-opt)
(if (null? modifier-opt)
#`(define-record-accessor #,pred #,field #,accessor)
#`(begin
(define-record-accessor #,pred #,field #,accessor)
(define-record-modifier #,pred #,field #,(car modifier-opt)))))
(define-syntax (define-record-type name ctor pred . fields)
#`(begin
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
(export define-record-type)
;; 6.1. Equivalence predicates

5
t/syntax-rules.scm → contrib/20.r7rs/t/syntax-rules.scm
View File

@ -1,8 +1,7 @@
(import (picrin base)
(picrin syntax-rules)
(import (scheme base)
(picrin test))
(test-begin)
(test-begin "syntax-rules")
(define-syntax extract?
(syntax-rules ()

2
contrib/30.readline/t/test.scm
View File

@ -2,7 +2,7 @@
(picrin readline history)
(picrin test))
(define testfile "picrin_readline_test_file")
(define testfile "/tmp/picrin_readline_test_file")
(test-begin)
(test 0 (history-length))

1
contrib/30.test/nitro.mk Normal file
View File

@ -0,0 +1 @@
CONTRIB_LIBS += $(wildcard contrib/30.test/*.scm)

4
piclib/picrin/test.scm → contrib/30.test/test.scm
View File

@ -1,6 +1,6 @@
(define-library (picrin test)
(import (picrin base)
(picrin syntax-rules))
(import (scheme base)
(scheme write))
(define test-counter 0)
(define counter 0)

24
contrib/50.destructuring-bind/lambda.scm Normal file
View File

@ -0,0 +1,24 @@
(define-library (picrin destructuring-bind)
(import (picrin base)
(picrin macro))
(define-syntax (destructuring-bind formal value . body)
(cond
((variable? formal)
#`(let ((#,formal #,value))
#,@body))
((pair? formal)
#`(let ((value #,value))
(destructuring-bind #,(car formal) (car value)
(destructuring-bind #,(cdr formal) (cdr value)
#,@body))))
((vector? formal)
;; TODO
(error "fixme"))
(else
#`(if (equal? #,value '#,formal)
(begin
#,@body)
(error "match failure" #,value '#,formal)))))
(export destructuring-bind))

1
contrib/50.destructuring-bind/nitro.mk Normal file
View File

@ -0,0 +1 @@
CONTRIB_LIBS += $(wildcard contrib/50.destructuring-bind/*.scm)

8
piclib/picrin/array.scm → contrib/90.array/array.scm
View File

@ -1,6 +1,5 @@
(define-library (picrin array)
(import (picrin base)
(picrin record))
(import (scheme base))
(define-record-type <array>
(create-array data size head tail)
@ -10,11 +9,6 @@
(head array-head set-array-head!)
(tail array-tail set-array-tail!))
(define (floor-remainder i j)
(call-with-values (lambda () (floor/ i j))
(lambda (q r)
r)))
(define (translate ary i)
(floor-remainder i (array-size ary)))

6
contrib/90.array/nitro.mk Normal file
View File

@ -0,0 +1,6 @@
CONTRIB_LIBS += $(wildcard contrib/90.array/*.scm)
CONTRIB_TESTS += test-array
test-array: bin/picrin
bin/picrin contrib/90.array/t/array.scm

26
contrib/90.array/t/array.scm Normal file
View File

@ -0,0 +1,26 @@
(import (scheme base)
(scheme write)
(picrin array)
(picrin test))
(test-begin)
(define ary (make-array))
(array-push! ary 1)
(array-push! ary 2)
(array-push! ary 3)
(test 3 (array-pop! ary))
(test 2 (array-pop! ary))
(test 1 (array-pop! ary))
(array-unshift! ary 1)
(array-unshift! ary 2)
(array-unshift! ary 3)
(test 3 (array-shift! ary))
(test 2 (array-shift! ary))
(test 1 (array-shift! ary))
(test-end)

18
extlib/benz/boot.c
View File

@ -646,11 +646,6 @@ my $src = <<'EOL';
(library-export (car slot) (cdr slot))))))
(for-each export (cdr form)))))
(export define-library
cond-expand
import
export)
(export define lambda quote set! if begin define-macro
let let* letrec letrec*
let-values let*-values define-values
@ -1001,13 +996,12 @@ const char pic_boot[][80] = {
") . ,(list-ref spec 2)))\n (else\n (error \"malformed expo",
"rt\")))))\n (export\n (lambda (spec)\n (let ((slot (co",
"llect spec)))\n (library-export (car slot) (cdr slot))))))\n (f",
"or-each export (cdr form)))))\n\n(export define-library\n cond-expand\n ",
" import\n export)\n\n(export define lambda quote set! if begin define-macro",
"\n let let* letrec letrec*\n let-values let*-values define-values\n ",
" quasiquote unquote unquote-splicing\n and or\n cond case else ",
"=>\n do when unless\n parameterize\n define-syntax\n syn",
"tax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ",
" let-syntax letrec-syntax\n syntax-error)\n\n\n",
"or-each export (cdr form)))))\n\n(export define lambda quote set! if begin define-",
"macro\n let let* letrec letrec*\n let-values let*-values define-valu",
"es\n quasiquote unquote unquote-splicing\n and or\n cond case ",
"else =>\n do when unless\n parameterize\n define-syntax\n ",
" syntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n",
" let-syntax letrec-syntax\n syntax-error)\n\n\n",
"",
""
};

291
piclib/picrin/base.scm
View File

@ -1,291 +0,0 @@
(define-library (picrin base)
(export define
lambda
if
quote
set!
begin
define-macro)
(export syntax-error
define-syntax
let-syntax
letrec-syntax
syntax-quote
syntax-quasiquote
syntax-unquote
syntax-unquote-splicing)
(export let
let*
letrec
letrec*
quasiquote
unquote
unquote-splicing
and
or
cond
case
=>
else
do
when
unless)
(export let-values
let*-values
define-values)
(export eq?
eqv?
equal?)
(export undefined?)
(export boolean?
boolean=?
not)
(export symbol?
symbol->string
string->symbol
symbol=?)
(export char?
char->integer
integer->char
char=?
char<?
char>?
char<=?
char>=?)
(export number?
complex?
real?
rational?
integer?
exact?
inexact?
=
<
>
<=
>=
+
-
*
/
abs
floor/
truncate/
floor
ceiling
truncate
round
expt
number->string
string->number
finite?
infinite?
nan?
exp
log
sin
cos
tan
acos
asin
atan
sqrt)
(export pair?
cons
car
cdr
set-car!
set-cdr!
null?
caar
cadr
cdar
cddr)
(export list?
make-list
list
length
append
reverse
list-tail
list-ref
list-set!
list-copy
map
for-each
memq
memv
member
assq
assv
assoc)
(export bytevector?
bytevector
make-bytevector
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
bytevector-copy
bytevector-copy!
bytevector-append
bytevector->list
list->bytevector)
(export vector?
vector
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
vector-map
vector-for-each
list->vector
vector->list
string->vector
vector->string)
(export string?
string
make-string
string-length
string-ref
string-copy
string-append
string-map
string-for-each
string->list
list->string
string=?
string<?
string>?
string<=?
string>=?)
(export make-dictionary
dictionary?
dictionary
dictionary-ref
dictionary-set!
dictionary-size
dictionary-map
dictionary-for-each
dictionary->plist
plist->dictionary
dictionary->alist
alist->dictionary)
(export make-record
record?
record-type
record-ref
record-set!)
(export current-input-port
current-output-port
current-error-port
call-with-port
port?
input-port?
output-port?
textual-port?
binary-port?
port-open?
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 make-parameter
parameterize)
(export make-identifier
identifier?
identifier-variable
identifier-environment
variable?
variable=?)
(export make-library
find-library
current-library
library-exports
library-environment)
(export call-with-current-continuation
call/cc
escape
dynamic-wind
values
call-with-values)
(export with-exception-handler
raise
raise-continuable
error
make-error-object
error-object?
error-object-message
error-object-irritants
error-object-type)
(export procedure?
apply
attribute)
(export read)
(export write
write-simple
write-shared
display)
(export eval)
(export features))

3
piclib/picrin/control.scm
View File

@ -1,3 +0,0 @@
(define-library (picrin control)
(import (picrin base))
(export escape))

37
piclib/picrin/experimental/lambda.scm
View File

@ -1,37 +0,0 @@
(define-library (picrin experimental lambda)
(import (picrin base)
(picrin macro))
(define-syntax (destructuring-let formal value . body)
(cond
((variable? formal)
#`(let ((#,formal #,value))
#,@body))
((pair? formal)
#`(let ((value #,value))
(destructuring-let #,(car formal) (car value)
(destructuring-let #,(cdr formal) (cdr value)
#,@body))))
((vector? formal)
;; TODO
(error "fixme"))
(else
#`(if (equal? #,value '#,formal)
(begin
#,@body)
(error "match failure" #,value '#,formal)))))
(define-syntax (destructuring-lambda formal . body)
#`(lambda args
(destructuring-let #,formal args #,@body)))
(define-syntax (destructuring-define formal . body)
(if (variable? formal)
#`(define #,formal #,@body)
#`(destructuring-define #,(car formal)
(destructuring-lambda #,(cdr formal)
#,@body))))
(export (rename destructuring-let let)
(rename destructuring-lambda lambda)
(rename destructuring-define define)))

59
piclib/picrin/record.scm
View File

@ -1,59 +0,0 @@
(define-library (picrin record)
(import (picrin base)
(picrin macro))
;; record meta type
(define ((boot-make-record-type <meta-type>) name)
(let ((rectype (make-record <meta-type>)))
(record-set! rectype 'name name)
rectype))
(define <record-type>
(let ((<record-type> ((boot-make-record-type #t) 'record-type)))
(record-set! <record-type> '@@type <record-type>)
<record-type>))
(define make-record-type (boot-make-record-type <record-type>))
;; define-record-type
(define-syntax (define-record-constructor type name . fields)
(let ((record #'record))
#`(define (#,name . #,fields)
(let ((#,record (make-record #,type)))
#,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
#,record))))
(define-syntax (define-record-predicate type name)
#`(define (#,name obj)
(and (record? obj)
(eq? (record-type obj) #,type))))
(define-syntax (define-record-accessor pred field accessor)
#`(define (#,accessor record)
(if (#,pred record)
(record-ref record '#,field)
(error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(define-syntax (define-record-modifier pred field modifier)
#`(define (#,modifier record val)
(if (#,pred record)
(record-set! record '#,field val)
(error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
(define-syntax (define-record-field pred field accessor . modifier-opt)
(if (null? modifier-opt)
#`(define-record-accessor #,pred #,field #,accessor)
#`(begin
(define-record-accessor #,pred #,field #,accessor)
(define-record-modifier #,pred #,field #,(car modifier-opt)))))
(define-syntax (define-record-type name ctor pred . fields)
#`(begin
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
(export define-record-type))

244
piclib/picrin/syntax-rules.scm
View File

@ -1,244 +0,0 @@
(define-library (picrin syntax-rules)
(import (picrin base)
(picrin macro))
(define-syntax (define-auxiliary-syntax var)
#`(define-macro #,var
(lambda _
(error "invalid use of auxiliary syntax" '#,var))))
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define (succ n)
(+ n 1))
(define (pred n)
(if (= n 0)
0
(- n 1)))
(define (every? args)
(if (null? args)
#t
(if (car args)
(every? (cdr args))
#f)))
(define (filter f list)
(if (null? list)
'()
(if (f (car list))
(cons (car list)
(filter f (cdr list)))
(filter f (cdr list)))))
(define (take-tail n list)
(let drop ((n (- (length list) n)) (list list))
(if (= n 0)
list
(drop (- n 1) (cdr list)))))
(define (drop-tail n list)
(let take ((n (- (length list) n)) (list list))
(if (= n 0)
'()
(cons (car list) (take (- n 1) (cdr list))))))
(define (map-keys f assoc)
(map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
(define (map-values f assoc)
(map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
;; TODO
;; - placeholder
;; - vector
;; - (... template) pattern
;; p ::= constant
;; | var
;; | (p ... . p) (in input pattern, tail p should be a proper list)
;; | (p . p)
(define (compile ellipsis literals rules)
(define (constant? obj)
(and (not (pair? obj))
(not (variable? obj))))
(define (literal? obj)
(and (variable? obj)
(memq obj literals)))
(define (many? pat)
(and (pair? pat)
(pair? (cdr pat))
(variable? (cadr pat))
(variable=? (cadr pat) ellipsis)))
(define (pattern-validator pat) ; pattern -> validator
(letrec
((pattern-validator
(lambda (pat form)
(cond
((constant? pat)
#`(equal? '#,pat #,form))
((literal? pat)
#`(and (variable? #,form) (variable=? #'#,pat #,form)))
((variable? pat)
#t)
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
#`(and (list? #,form)
(>= (length #,form) #,(length (cddr pat)))
(every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head))
#,(pattern-validator (cddr pat) tail))))
((pair? pat)
#`(and (pair? #,form)
#,(pattern-validator (car pat) #`(car #,form))
#,(pattern-validator (cdr pat) #`(cdr #,form))))
(else
#f)))))
(pattern-validator pat 'it)))
(define (pattern-variables pat) ; pattern -> (freevar)
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`(,pat))
((many? pat)
(append (pattern-variables (car pat))
(pattern-variables (cddr pat))))
((pair? pat)
(append (pattern-variables (car pat))
(pattern-variables (cdr pat))))))
(define (pattern-levels pat) ; pattern -> ((var * int))
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`((,pat . 0)))
((many? pat)
(append (map-values succ (pattern-levels (car pat)))
(pattern-levels (cddr pat))))
((pair? pat)
(append (pattern-levels (car pat))
(pattern-levels (cdr pat))))))
(define (pattern-selectors pat) ; pattern -> ((var * selector))
(letrec
((pattern-selectors
(lambda (pat form)
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`((,pat . ,form)))
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
(let ((envs (pattern-selectors (car pat) 'it)))
(append
(map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs)
(pattern-selectors (cddr pat) tail)))))
((pair? pat)
(append (pattern-selectors (car pat) #`(car #,form))
(pattern-selectors (cdr pat) #`(cdr #,form))))))))
(pattern-selectors pat 'it)))
(define (template-representation pat levels selectors)
(cond
((constant? pat)
pat)
((variable? pat)
(let ((it (assq pat levels)))
(if it
(if (= 0 (cdr it))
(cdr (assq pat selectors))
(error "unmatched pattern variable level" pat))
#`(#,'rename '#,pat))))
((many? pat)
(letrec*
((inner-pat
(car pat))
(inner-levels
(map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels))
(inner-freevars
(filter (lambda (v) (assq v levels)) (pattern-variables inner-pat)))
(inner-vars
;; select only vars declared with ellipsis
(filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars))
(inner-tmps
(map (lambda (v) #'it) inner-vars))
(inner-selectors
;; first env '(map cons ...)' shadows second env 'selectors'
(append (map cons inner-vars inner-tmps) selectors))
(inner-rep
(template-representation inner-pat inner-levels inner-selectors))
(sorted-selectors
(map (lambda (v) (assq v selectors)) inner-vars))
(list-of-selectors
;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs)
(map cdr sorted-selectors)))
(let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors))
(rep2 (template-representation (cddr pat) levels selectors)))
#`(append #,rep1 #,rep2))))
((pair? pat)
#`(cons #,(template-representation (car pat) levels selectors)
#,(template-representation (cdr pat) levels selectors)))))
(define (compile-rule pattern template)
(let ((levels
(pattern-levels pattern))
(selectors
(pattern-selectors pattern)))
(template-representation template levels selectors)))
(define (compile-rules rules)
(if (null? rules)
#`(error "unmatch")
(let ((pattern (car (car rules)))
(template (cadr (car rules))))
#`(if #,(pattern-validator pattern)
#,(compile-rule pattern template)
#,(compile-rules (cdr rules))))))
(define (compile rules)
#`(call-with-current-environment
(lambda (env)
(letrec
((#,'rename (let ((reg (make-register)))
(lambda (x)
(if (undefined? (reg x))
(let ((id (make-identifier x env)))
(reg x id)
id)
(reg x))))))
(lambda #,'it
#,(compile-rules rules))))))
(let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
(compile rules)))
(define-syntax (syntax-rules . args)
(if (list? (car args))
#`(syntax-rules ... #,@args)
(let ((ellipsis (car args))
(literals (car (cdr args)))
(rules (cdr (cdr args))))
(compile ellipsis literals rules))))
(export syntax-rules
_
...))

42
t/array.scm
View File

@ -1,42 +0,0 @@
(import (scheme base)
(scheme write)
(picrin array))
(define ary (make-array))
(write ary)
(newline)
(array-push! ary 1)
(write ary)
(newline)
(array-push! ary 2)
(write ary)
(newline)
(array-push! ary 3)
(write ary)
(newline)
(write (array-pop! ary))
(newline)
(write (array-pop! ary))
(newline)
(write (array-pop! ary))
(newline)
(write ary)
(newline)
(array-unshift! ary 1)
(write ary)
(newline)
(array-unshift! ary 2)
(write ary)
(newline)
(array-unshift! ary 3)
(write ary)
(newline)
(write (array-shift! ary))
(newline)
(write (array-shift! ary))
(newline)
(write (array-shift! ary))
(newline)