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

eliminate (scheme cxr) dependency

This commit is contained in:
Yuichi Nishiwaki 2014-07-19 14:25:22 +09:00
parent 301c97245c
commit 6a203d236a
2 changed files with 47 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
piclib/CMakeLists.txt
View File

@ -1,9 +1,9 @@
list(APPEND PICLIB_SCHEME_LIBS list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
${PROJECT_SOURCE_DIR}/piclib/prelude.scm ${PROJECT_SOURCE_DIR}/piclib/prelude.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/scheme/cxr.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
${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

92
piclib/prelude.scm
View File

@ -27,9 +27,9 @@
(lambda (expr r compare) (lambda (expr r compare)
(if (symbol? (cadr expr)) (if (symbol? (cadr expr))
(begin (begin
(define name (cadr expr)) (define name (car (cdr expr)))
(define bindings (caddr expr)) (define bindings (car (cdr (cdr expr))))
(define body (cdddr expr)) (define body (cdr (cdr (cdr expr))))
(list (r 'let) '() (list (r 'let) '()
(list (r 'define) name (list (r 'define) name
(cons (r 'lambda) (cons (map car bindings) body))) (cons (r 'lambda) (cons (map car bindings) body)))
@ -46,18 +46,20 @@
(let ((clauses (cdr expr))) (let ((clauses (cdr expr)))
(if (null? clauses) (if (null? clauses)
#f #f
(if (compare (r 'else) (caar clauses)) (begin
(cons (r 'begin) (cdar clauses)) (define clause (car clauses))
(if (if (>= (length (car clauses)) 2) (if (compare (r 'else) (car clause))
(compare (r '=>) (cadar clauses)) (cons (r 'begin) (cdr clause))
#f) (if (if (>= (length clause) 2)
(list (r 'let) (list (list (r 'x) (caar clauses))) (compare (r '=>) (list-ref clause 1))
(list (r 'if) (r 'x) #f)
(list (caddar clauses) (r 'x)) (list (r 'let) (list (list (r 'x) (car clause)))
(cons (r 'cond) (cdr clauses)))) (list (r 'if) (r 'x)
(list (r 'if) (caar clauses) (list (list-ref clause 2) (r 'x))
(cons (r 'begin) (cdar clauses)) (cons (r 'cond) (cdr clauses))))
(cons (r 'cond) (cdr clauses)))))))))) (list (r 'if) (car clause)
(cons (r 'begin) (cdr clause))
(cons (r 'cond) (cdr clauses)))))))))))
(define-syntax and (define-syntax and
(er-macro-transformer (er-macro-transformer
@ -203,9 +205,9 @@
(define-syntax do (define-syntax do
(er-macro-transformer (er-macro-transformer
(lambda (form r compare) (lambda (form r compare)
(let ((bindings (cadr form)) (let ((bindings (car (cdr form)))
(finish (caddr form)) (finish (car (cdr (cdr form))))
(body (cdddr form))) (body (cdr (cdr (cdr form)))))
`(,(r 'let) ,(r 'loop) ,(map (lambda (x) `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
(list (car x) (cadr x))) (list (car x) (cadr x)))
bindings) bindings)
@ -245,16 +247,18 @@
,(let loop ((clauses clauses)) ,(let loop ((clauses clauses))
(if (null? clauses) (if (null? clauses)
#f #f
`(,(r 'if) ,(if (compare (r 'else) (caar clauses)) (begin
'#t (define clause (car clauses))
`(,(r 'or) `(,(r 'if) ,(if (compare (r 'else) (car clause))
,@(map (lambda (x) '#t
`(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) `(,(r 'or)
(caar clauses)))) ,@(map (lambda (x)
,(if (compare (r '=>) (cadar clauses)) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
`(,(caddar clauses) ,(r 'key)) (car clause))))
`(,(r 'begin) ,@(cdar clauses))) ,(if (compare (r '=>) (list-ref clause 1))
,(loop (cdr clauses)))))))))) `(,(list-ref clause 2) ,(r 'key))
`(,(r 'begin) ,@(cdr clause)))
,(loop (cdr clauses)))))))))))
(define-syntax letrec-syntax (define-syntax letrec-syntax
(er-macro-transformer (er-macro-transformer
@ -279,7 +283,6 @@
;;; multiple value ;;; multiple value
(define-library (picrin multiple-value) (define-library (picrin multiple-value)
(import (scheme base) (import (scheme base)
(scheme cxr)
(picrin macro) (picrin macro)
(picrin core-syntax)) (picrin core-syntax))
@ -364,7 +367,6 @@
;;; parameter ;;; parameter
(define-library (picrin parameter) (define-library (picrin parameter)
(import (scheme base) (import (scheme base)
(scheme cxr)
(picrin macro) (picrin macro)
(picrin core-syntax) (picrin core-syntax)
(picrin var) (picrin var)
@ -434,8 +436,7 @@
;;; Record Type ;;; Record Type
(define-library (picrin record) (define-library (picrin record)
(import (scheme base) (import (scheme base)
(scheme cxr) (picrin macro)
(picrin macro)
(picrin core-syntax)) (picrin core-syntax))
(define record-marker (list 'record-marker)) (define record-marker (list 'record-marker))
@ -541,9 +542,9 @@
(define-syntax define-record-field (define-syntax define-record-field
(ir-macro-transformer (ir-macro-transformer
(lambda (form inject compare?) (lambda (form inject compare?)
(let ((type (cadr form)) (let ((type (car (cdr form)))
(field-tag (caddr form)) (field-tag (car (cdr (cdr form))))
(acc-mod (cdddr form))) (acc-mod (cdr (cdr (cdr form)))))
(if (= 1 (length acc-mod)) (if (= 1 (length acc-mod))
`(define ,(car acc-mod) `(define ,(car acc-mod)
(record-accessor ,type ',field-tag)) (record-accessor ,type ',field-tag))
@ -557,9 +558,9 @@
(ir-macro-transformer (ir-macro-transformer
(lambda (form inject compare?) (lambda (form inject compare?)
(let ((type (cadr form)) (let ((type (cadr form))
(constructor (caddr form)) (constructor (car (cdr (cdr form))))
(predicate (cadddr form)) (predicate (car (cdr (cdr (cdr form)))))
(field-tag (cddddr form))) (field-tag (cdr (cdr (cdr (cdr form))))))
`(begin `(begin
(define ,type (define ,type
(make-record-type ',type ',(cdr constructor))) (make-record-type ',type ',(cdr constructor)))
@ -987,8 +988,7 @@
;;; syntax-rules ;;; syntax-rules
(define-library (picrin syntax-rules) (define-library (picrin syntax-rules)
(import (scheme base) (import (scheme base)
(scheme cxr) (picrin macro))
(picrin macro))
;;; utility functions ;;; utility functions
(define (reverse* l) (define (reverse* l)
@ -1261,9 +1261,9 @@
((compare (car clauses) 'mismatch) ((compare (car clauses) 'mismatch)
`(,_syntax-error "invalid rule")) `(,_syntax-error "invalid rule"))
(else (else
(let ((vars (car (car clauses))) (let ((vars (list-ref (car clauses) 0))
(match (cadr (car clauses))) (match (list-ref (car clauses) 1))
(expand (caddr (car clauses)))) (expand (list-ref (car clauses) 2)))
`(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
(,_let ((result (,_call/cc (,_lambda (exit) ,match)))) (,_let ((result (,_call/cc (,_lambda (exit) ,match))))
(,_if result (,_if result
@ -1294,9 +1294,9 @@
(let ((form (normalize-form form))) (let ((form (normalize-form form)))
(if form (if form
(let ((ellipsis (cadr form)) (let ((ellipsis (list-ref form 1))
(literals (caddr form)) (literals (list-ref form 2))
(rules (cdddr form))) (rules (list-tail form 3)))
(let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
rules))) rules)))
`(,_er-macro-transformer `(,_er-macro-transformer