diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 6898de1b..50b59f9b 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -1,7 +1,12 @@ list(APPEND PICLIB_SCHEME_LIBS + ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm # the only dependency prelude requires ${PROJECT_SOURCE_DIR}/piclib/prelude.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/array.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/case-lambda.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm new file mode 100644 index 00000000..e05003d3 --- /dev/null +++ b/piclib/picrin/macro.scm @@ -0,0 +1,158 @@ +;;; Hygienic Macros + +(define-library (picrin macro) + (import (scheme base) + (picrin dictionary)) + + ;; assumes no derived expressions are provided yet + + (define (memq obj list) + (if (null? list) + #f + (if (eq? obj (car list)) + list + (memq obj (cdr list))))) + + (define (list->vector list) + (define vector (make-vector (length list))) + (define (go list i) + (if (null? list) + vector + (begin + (vector-set! vector i (car list)) + (go (cdr list) (+ i 1))))) + (go list 0)) + + (define (vector->list vector) + (define (go i) + (if (= i (vector-length vector)) + '() + (cons (vector-ref vector i) + (go (+ i 1))))) + (go 0)) + + (define (vector-map proc expr) + (list->vector (map proc (vector->list expr)))) + + (define (walk proc expr) + (if (null? expr) + '() + (if (pair? expr) + (cons (walk proc (car expr)) + (walk proc (cdr expr))) + (if (vector? expr) + (vector-map proc expr) + (proc expr))))) + + (define (make-syntactic-closure env free form) + (define cache (make-dictionary)) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (if (memq atom free) + atom + (if (dictionary-has? cache atom) + (dictionary-ref cache atom) + (begin + (define id (make-identifier atom env)) + (dictionary-set! cache atom id) + id))))) + form)) + + (define (close-syntax form env) + (make-syntactic-closure env '() form)) + + (define-syntax capture-syntactic-environment + (lambda (form use-env mac-env) + (list (cadr form) (list (make-identifier 'quote mac-env) mac-env)))) + + (define (sc-macro-transformer f) + (lambda (expr use-env mac-env) + (make-syntactic-closure mac-env '() (f expr use-env)))) + + (define (rsc-macro-transformer f) + (lambda (expr use-env mac-env) + (make-syntactic-closure use-env '() (f expr mac-env)))) + + (define (er-macro-transformer f) + (lambda (expr use-env mac-env) + + (define cache (make-dictionary)) + + (define (rename sym) + (if (dictionary-has? cache sym) + (dictionary-ref cache sym) + (begin + (define id (make-identifier sym mac-env)) + (dictionary-set! cache sym id) + id))) + + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? use-env x use-env y)))) + + (f expr rename compare))) + + (define (ir-macro-transformer f) + (lambda (expr use-env mac-env) + + (define protects (make-dictionary)) + + (define (wrap expr) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (begin + (define id (make-identifier atom use-env)) + (dictionary-set! protects id atom) ; lookup *atom* from id + id))) + expr)) + + (define (unwrap expr) + (define cache (make-dictionary)) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (if (dictionary-has? protects atom) + (dictionary-ref protects atom) + (if (dictionary-has? cache atom) + (dictionary-ref cache atom) + (begin + ;; implicit renaming + (define id (make-identifier atom mac-env)) + (dictionary-set! cache atom id) + id))))) + expr)) + + (define cache (make-dictionary)) + + (define (inject sym) + (if (dictionary-has? cache sym) + (dictionary-ref cache sym) + (begin + (define id (make-identifier sym use-env)) + (dictionary-set! cache sym id) + id))) + + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? mac-env x mac-env y)))) + + (unwrap (f (wrap expr) inject compare)))) + + (export make-syntactic-closure + close-syntax + capture-syntactic-environment + sc-macro-transformer + rsc-macro-transformer + er-macro-transformer + ir-macro-transformer)) diff --git a/piclib/prelude.scm b/piclib/prelude.scm index 6aede272..9bc59aa6 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -1,201 +1,13 @@ -;;; Appendix A. Standard Libraries CxR -(define-library (scheme cxr) - (import (scheme base)) - - (define (caaar p) (car (caar p))) - (define (caadr p) (car (cadr p))) - (define (cadar p) (car (cdar p))) - (define (caddr p) (car (cddr p))) - (define (cdaar p) (cdr (caar p))) - (define (cdadr p) (cdr (cadr p))) - (define (cddar p) (cdr (cdar p))) - (define (cdddr p) (cdr (cddr p))) - (define (caaaar p) (caar (caar p))) - (define (caaadr p) (caar (cadr p))) - (define (caadar p) (caar (cdar p))) - (define (caaddr p) (caar (cddr p))) - (define (cadaar p) (cadr (caar p))) - (define (cadadr p) (cadr (cadr p))) - (define (caddar p) (cadr (cdar p))) - (define (cadddr p) (cadr (cddr p))) - (define (cdaaar p) (cdar (caar p))) - (define (cdaadr p) (cdar (cadr p))) - (define (cdadar p) (cdar (cdar p))) - (define (cdaddr p) (cdar (cddr p))) - (define (cddaar p) (cddr (caar p))) - (define (cddadr p) (cddr (cadr p))) - (define (cdddar p) (cddr (cdar p))) - (define (cddddr p) (cddr (cddr p))) - - (export caaar caadr cadar caddr - cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr - cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr - cddaar cddadr cdddar cddddr)) - -;;; hygienic macros -(define-library (picrin macro) - (import (scheme base) - (picrin dictionary)) - - (define (memq obj list) - (if (null? list) - #f - (if (eq? obj (car list)) - list - (memq obj (cdr list))))) - - (define (list->vector list) - (define vector (make-vector (length list))) - (define (go list i) - (if (null? list) - vector - (begin - (vector-set! vector i (car list)) - (go (cdr list) (+ i 1))))) - (go list 0)) - - (define (vector->list vector) - (define (go i) - (if (= i (vector-length vector)) - '() - (cons (vector-ref vector i) - (go (+ i 1))))) - (go 0)) - - (define (vector-map proc expr) - (list->vector (map proc (vector->list expr)))) - - (define (walk proc expr) - (if (null? expr) - '() - (if (pair? expr) - (cons (walk proc (car expr)) - (walk proc (cdr expr))) - (if (vector? expr) - (vector-map proc expr) - (proc expr))))) - - (define (make-syntactic-closure env free form) - (define cache (make-dictionary)) - (walk - (lambda (atom) - (if (not (symbol? atom)) - atom - (if (memq atom free) - atom - (if (dictionary-has? cache atom) - (dictionary-ref cache atom) - (begin - (define id (make-identifier atom env)) - (dictionary-set! cache atom id) - id))))) - form)) - - (define (close-syntax form env) - (make-syntactic-closure env '() form)) - - (define-syntax capture-syntactic-environment - (lambda (form use-env mac-env) - (list (cadr form) (list (make-identifier 'quote mac-env) mac-env)))) - - (define (sc-macro-transformer f) - (lambda (expr use-env mac-env) - (make-syntactic-closure mac-env '() (f expr use-env)))) - - (define (rsc-macro-transformer f) - (lambda (expr use-env mac-env) - (make-syntactic-closure use-env '() (f expr mac-env)))) - - (define (er-macro-transformer f) - (lambda (expr use-env mac-env) - - (define cache (make-dictionary)) - - (define (rename sym) - (if (dictionary-has? cache sym) - (dictionary-ref cache sym) - (begin - (define id (make-identifier sym mac-env)) - (dictionary-set! cache sym id) - id))) - - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) - - (f expr rename compare))) - - (define (ir-macro-transformer f) - (lambda (expr use-env mac-env) - - (define protects (make-dictionary)) - - (define (wrap expr) - (walk - (lambda (atom) - (if (not (symbol? atom)) - atom - (begin - (define id (make-identifier atom use-env)) - (dictionary-set! protects id atom) ; lookup *atom* from id - id))) - expr)) - - (define (unwrap expr) - (define cache (make-dictionary)) - (walk - (lambda (atom) - (if (not (symbol? atom)) - atom - (if (dictionary-has? protects atom) - (dictionary-ref protects atom) - (if (dictionary-has? cache atom) - (dictionary-ref cache atom) - (begin - ;; implicit renaming - (define id (make-identifier atom mac-env)) - (dictionary-set! cache atom id) - id))))) - expr)) - - (define cache (make-dictionary)) - - (define (inject sym) - (if (dictionary-has? cache sym) - (dictionary-ref cache sym) - (begin - (define id (make-identifier sym use-env)) - (dictionary-set! cache sym id) - id))) - - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? mac-env x mac-env y)))) - - (unwrap (f (wrap expr) inject compare)))) - - (export make-syntactic-closure - close-syntax - capture-syntactic-environment - sc-macro-transformer - rsc-macro-transformer - er-macro-transformer - ir-macro-transformer)) - ;;; core syntaces (define-library (picrin core-syntax) (import (scheme base) - (scheme cxr) (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) @@ -215,9 +27,9 @@ (lambda (expr r compare) (if (symbol? (cadr expr)) (begin - (define name (cadr expr)) - (define bindings (caddr expr)) - (define body (cdddr expr)) + (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))) @@ -234,23 +46,20 @@ (let ((clauses (cdr expr))) (if (null? clauses) #f - (if (compare (r 'else) (caar clauses)) - (cons (r 'begin) (cdar clauses)) - (if (if (>= (length (car clauses)) 2) - (compare (r '=>) (cadar clauses)) - #f) - (list (r 'let) (list (list (r 'x) (caar clauses))) - (list (r 'if) (r 'x) - (list (caddar clauses) (r 'x)) - (cons (r 'cond) (cdr clauses)))) - (list (r 'if) (caar clauses) - (cons (r 'begin) (cdar clauses)) - (cons (r 'cond) (cdr clauses)))))))))) - - (define (single? list) - (if (pair? list) - (null? (cdr list)) - #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 @@ -259,7 +68,7 @@ (cond ((null? exprs) #t) - ((single? exprs) + ((= (length exprs) 1) (car exprs)) (else (list (r 'let) (list (list (r 'it) (car exprs))) @@ -274,7 +83,7 @@ (cond ((null? exprs) #t) - ((single? exprs) + ((= (length exprs) 1) (car exprs)) (else (list (r 'let) (list (list (r 'it) (car exprs))) @@ -282,15 +91,6 @@ (r 'it) (cons (r 'or) (cdr exprs)))))))))) - (define (quasiquote? form compare?) - (and (pair? form) (compare? (car form) 'quasiquote))) - - (define (unquote? form compare?) - (and (pair? form) (compare? (car form) 'unquote))) - - (define (unquote-splicing? form compare?) - (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing))) - (define (list->vector list) (let ((vector (make-vector (length list)))) (let loop ((list list) (i 0)) @@ -311,17 +111,27 @@ (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 compare) + ((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 compare) + ((unquote-splicing? expr) (if (= depth 1) (list 'append (car (cdr (car expr))) @@ -332,7 +142,7 @@ (qq (- depth 1) (car (cdr (car expr))))) (qq depth (cdr expr))))) ;; quasiquote - ((quasiquote? expr compare) + ((quasiquote? expr) (list 'list (list 'quote (inject 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) @@ -395,9 +205,9 @@ (define-syntax do (er-macro-transformer (lambda (form r compare) - (let ((bindings (cadr form)) - (finish (caddr form)) - (body (cdddr form))) + (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) @@ -437,15 +247,18 @@ ,(let loop ((clauses clauses)) (if (null? clauses) #f - `(,(r 'if) ,(if (compare (r 'else) (caar clauses)) - '#t - `(,(r 'or) - ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) - (caar clauses)))) - ,(if (compare (r '=>) (cadar clauses)) - `(,(caddar clauses) ,(r 'key)) - `(,(r 'begin) ,@(cdar clauses))) - ,(loop (cdr clauses)))))))))) + (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 @@ -458,11 +271,6 @@ formal) ,@body))))) - (define-syntax syntax-error - (er-macro-transformer - (lambda (expr rename compare) - (apply error (cdr expr))))) - (export let let* letrec letrec* quasiquote unquote unquote-splicing and or @@ -471,13 +279,20 @@ letrec-syntax _ ... syntax-error)) +(import (picrin core-syntax)) + +(export let let* letrec letrec* + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + letrec-syntax + _ ... syntax-error) ;;; multiple value -(define-library (picrin multiple-value) +(define-library (picrin values) (import (scheme base) - (scheme cxr) - (picrin macro) - (picrin core-syntax)) + (picrin macro)) (define-syntax let*-values (er-macro-transformer @@ -522,18 +337,6 @@ expr) (reverse list))) - (define (predefine var) - `(define ,var #f)) - - (define (predefines vars) - (map predefine vars)) - - (define (assign var val) - `(set! ,var ,val)) - - (define (assigns vars vals) - (map assign vars vals)) - (define uniq (let ((counter 0)) (lambda (x) @@ -548,10 +351,15 @@ (formal* (walk uniq formal)) (exprs (cddr form))) `(begin - ,@(predefines (flatten formal)) + ,@(map + (lambda (var) `(define ,var #f)) + (flatten formal)) (call-with-values (lambda () ,@exprs) (lambda ,formal* - ,@(assigns (flatten formal) (flatten formal*))))))))) + ,@(map + (lambda (var val) `(set! ,var ,val)) + (flatten formal) + (flatten formal*))))))))) (export let-values let*-values @@ -560,9 +368,7 @@ ;;; parameter (define-library (picrin parameter) (import (scheme base) - (scheme cxr) (picrin macro) - (picrin core-syntax) (picrin var) (picrin attribute) (picrin dictionary)) @@ -630,9 +436,7 @@ ;;; Record Type (define-library (picrin record) (import (scheme base) - (scheme cxr) - (picrin macro) - (picrin core-syntax)) + (picrin macro)) (define record-marker (list 'record-marker)) @@ -737,9 +541,9 @@ (define-syntax define-record-field (ir-macro-transformer (lambda (form inject compare?) - (let ((type (cadr form)) - (field-tag (caddr form)) - (acc-mod (cdddr form))) + (let ((type (car (cdr form))) + (field-tag (car (cdr (cdr form)))) + (acc-mod (cdr (cdr (cdr form))))) (if (= 1 (length acc-mod)) `(define ,(car acc-mod) (record-accessor ,type ',field-tag)) @@ -753,9 +557,9 @@ (ir-macro-transformer (lambda (form inject compare?) (let ((type (cadr form)) - (constructor (caddr form)) - (predicate (cadddr form)) - (field-tag (cddddr form))) + (constructor (car (cdr (cdr form)))) + (predicate (car (cdr (cdr (cdr form))))) + (field-tag (cdr (cdr (cdr (cdr form)))))) `(begin (define ,type (make-record-type ',type ',(cdr constructor))) @@ -768,22 +572,13 @@ `(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x))) field-tag)))))) - (export define-record-type vector?)) + (export define-record-type)) (import (picrin macro) - (picrin core-syntax) - (picrin multiple-value) + (picrin values) (picrin parameter) (picrin record)) -(export let let* letrec letrec* - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - letrec-syntax - _ ... syntax-error) - (export let-values let*-values define-values) @@ -791,8 +586,7 @@ (export make-parameter parameterize) -(export vector? ; override definition - define-record-type) +(export define-record-type) (define (every pred list) (if (null? list) @@ -1158,25 +952,13 @@ (export call-with-port) -(define-library (scheme file) - (import (scheme base)) - - (define (call-with-input-file filename callback) - (call-with-port (open-input-file filename) callback)) - - (define (call-with-output-file filename callback) - (call-with-port (open-output-file filename) callback)) - - (export call-with-input-file - call-with-output-file)) - ;;; include syntax (import (scheme read) (scheme file)) (define (read-many filename) - (call-with-input-file filename + (call-with-port (open-input-file filename) (lambda (port) (let loop ((expr (read port)) (exprs '())) (if (eof-object? expr) @@ -1192,53 +974,10 @@ (export include) -;;; Appendix A. Standard Libraries Lazy -(define-library (scheme lazy) - (import (scheme base) - (picrin macro)) - - (define-record-type promise - (make-promise% done obj) - promise? - (done promise-done? promise-done!) - (obj promise-value promise-value!)) - - (define-syntax delay-force - (ir-macro-transformer - (lambda (form rename compare?) - (let ((expr (cadr form))) - `(make-promise% #f (lambda () ,expr)))))) - - (define-syntax delay - (ir-macro-transformer - (lambda (form rename compare?) - (let ((expr (cadr form))) - `(delay-force (make-promise% #t ,expr)))))) - - (define (promise-update! new old) - (promise-done! old (promise-done? new)) - (promise-value! old (promise-value new))) - - (define (force promise) - (if (promise-done? promise) - (promise-value promise) - (let ((promise* ((promise-value promise)))) - (unless (promise-done? promise) - (promise-update! promise* promise)) - (force promise)))) - - (define (make-promise obj) - (if (promise? obj) - obj - (make-promise% #t obj))) - - (export delay-force delay force make-promise promise?)) - ;;; syntax-rules (define-library (picrin syntax-rules) (import (scheme base) - (scheme cxr) - (picrin macro)) + (picrin macro)) ;;; utility functions (define (reverse* l) @@ -1511,9 +1250,9 @@ ((compare (car clauses) 'mismatch) `(,_syntax-error "invalid rule")) (else - (let ((vars (car (car clauses))) - (match (cadr (car clauses))) - (expand (caddr (car clauses)))) + (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 @@ -1544,9 +1283,9 @@ (let ((form (normalize-form form))) (if form - (let ((ellipsis (cadr form)) - (literals (caddr form)) - (rules (cdddr 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 @@ -1560,32 +1299,3 @@ (import (picrin syntax-rules)) (export syntax-rules) -(define-library (scheme case-lambda) - (import (scheme base)) - - (define-syntax case-lambda - (syntax-rules () - ((case-lambda (params body0 ...) ...) - (lambda args - (let ((len (length args))) - (letrec-syntax - ((cl (syntax-rules ::: () - ((cl) - (error "no matching clause")) - ((cl ((p :::) . body) . rest) - (if (= len (length '(p :::))) - (apply (lambda (p :::) - . body) - args) - (cl . rest))) - ((cl ((p ::: . tail) . body) - . rest) - (if (>= len (length '(p :::))) - (apply - (lambda (p ::: . tail) - . body) - args) - (cl . rest)))))) - (cl (params body0 ...) ...))))))) - - (export case-lambda)) diff --git a/piclib/scheme/case-lambda.scm b/piclib/scheme/case-lambda.scm new file mode 100644 index 00000000..fff2b26c --- /dev/null +++ b/piclib/scheme/case-lambda.scm @@ -0,0 +1,29 @@ +(define-library (scheme case-lambda) + (import (scheme base)) + + (define-syntax case-lambda + (syntax-rules () + ((case-lambda (params body0 ...) ...) + (lambda args + (let ((len (length args))) + (letrec-syntax + ((cl (syntax-rules ::: () + ((cl) + (error "no matching clause")) + ((cl ((p :::) . body) . rest) + (if (= len (length '(p :::))) + (apply (lambda (p :::) + . body) + args) + (cl . rest))) + ((cl ((p ::: . tail) . body) + . rest) + (if (>= len (length '(p :::))) + (apply + (lambda (p ::: . tail) + . body) + args) + (cl . rest)))))) + (cl (params body0 ...) ...))))))) + + (export case-lambda)) diff --git a/piclib/scheme/cxr.scm b/piclib/scheme/cxr.scm new file mode 100644 index 00000000..e92c536f --- /dev/null +++ b/piclib/scheme/cxr.scm @@ -0,0 +1,36 @@ +;;; Appendix A. Standard Libraries CxR + +(define-library (scheme cxr) + (import (scheme base)) + + (define (caaar p) (car (caar p))) + (define (caadr p) (car (cadr p))) + (define (cadar p) (car (cdar p))) + (define (caddr p) (car (cddr p))) + (define (cdaar p) (cdr (caar p))) + (define (cdadr p) (cdr (cadr p))) + (define (cddar p) (cdr (cdar p))) + (define (cdddr p) (cdr (cddr p))) + (define (caaaar p) (caar (caar p))) + (define (caaadr p) (caar (cadr p))) + (define (caadar p) (caar (cdar p))) + (define (caaddr p) (caar (cddr p))) + (define (cadaar p) (cadr (caar p))) + (define (cadadr p) (cadr (cadr p))) + (define (caddar p) (cadr (cdar p))) + (define (cadddr p) (cadr (cddr p))) + (define (cdaaar p) (cdar (caar p))) + (define (cdaadr p) (cdar (cadr p))) + (define (cdadar p) (cdar (cdar p))) + (define (cdaddr p) (cdar (cddr p))) + (define (cddaar p) (cddr (caar p))) + (define (cddadr p) (cddr (cadr p))) + (define (cdddar p) (cddr (cdar p))) + (define (cddddr p) (cddr (cddr p))) + + (export caaar caadr cadar caddr + cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr + cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr + cddaar cddadr cdddar cddddr)) diff --git a/piclib/scheme/file.scm b/piclib/scheme/file.scm new file mode 100644 index 00000000..75c8bdd9 --- /dev/null +++ b/piclib/scheme/file.scm @@ -0,0 +1,11 @@ +(define-library (scheme file) + (import (scheme base)) + + (define (call-with-input-file filename callback) + (call-with-port (open-input-file filename) callback)) + + (define (call-with-output-file filename callback) + (call-with-port (open-output-file filename) callback)) + + (export call-with-input-file + call-with-output-file)) diff --git a/piclib/scheme/lazy.scm b/piclib/scheme/lazy.scm new file mode 100644 index 00000000..444dda40 --- /dev/null +++ b/piclib/scheme/lazy.scm @@ -0,0 +1,42 @@ +;;; Appendix A. Standard Libraries Lazy + +(define-library (scheme lazy) + (import (scheme base) + (picrin macro)) + + (define-record-type promise + (make-promise% done obj) + promise? + (done promise-done? promise-done!) + (obj promise-value promise-value!)) + + (define-syntax delay-force + (ir-macro-transformer + (lambda (form rename compare?) + (let ((expr (cadr form))) + `(make-promise% #f (lambda () ,expr)))))) + + (define-syntax delay + (ir-macro-transformer + (lambda (form rename compare?) + (let ((expr (cadr form))) + `(delay-force (make-promise% #t ,expr)))))) + + (define (promise-update! new old) + (promise-done! old (promise-done? new)) + (promise-value! old (promise-value new))) + + (define (force promise) + (if (promise-done? promise) + (promise-value promise) + (let ((promise* ((promise-value promise)))) + (unless (promise-done? promise) + (promise-update! promise* promise)) + (force promise)))) + + (define (make-promise obj) + (if (promise? obj) + obj + (make-promise% #t obj))) + + (export delay-force delay force make-promise promise?))