Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

cleanup whitespace

Browse source
This commit is contained in:
Alex Shinn 2020-05-25 18:52:33 +09:00
parent 7bbbb1fb2c
commit 6b449150fc
2 changed files with 104 additions and 98 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

172
lib/srfi/165.scm
View file

@ -21,7 +21,7 @@
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE. ;; SOFTWARE.
(define-record-type <computation-environment-variable> (define-record-type Computation-Environment-Variable
(make-environment-variable name default immutable? id) (make-environment-variable name default immutable? id)
environment-variable? environment-variable?
(name environment-variable-name) (name environment-variable-name)
@ -40,12 +40,12 @@
(define variable-comparator (define variable-comparator
(make-comparator environment-variable? (make-comparator environment-variable?
eq? eq?
(lambda (x y) (lambda (x y)
(< (environment-variable-id x) (< (environment-variable-id x)
(environment-variable-id y))) (environment-variable-id y)))
(lambda (x . y) (lambda (x . y)
(environment-variable-id x)))) (environment-variable-id x))))
(define default-computation (define default-computation
(make-computation-environment-variable 'default-computation #f #f)) (make-computation-environment-variable 'default-computation #f #f))
@ -81,14 +81,14 @@
(define var (make-environment-variable 'var e immutable i)) (define var (make-environment-variable 'var e immutable i))
... ...
(define (make-environment) (define (make-environment)
(let ((env (make-vector (+ n 2)))) (let ((env (make-vector (+ n 2))))
(environment-set-global! env (hash-table variable-comparator)) (environment-set-global! env (hash-table variable-comparator))
(environment-set-local! env (mapping variable-comparator)) (environment-set-local! env (mapping variable-comparator))
(vector-set! env (+ i 2) (box e)) (vector-set! env (+ i 2) (box e))
... ...
env)) env))
(define (run computation) (define (run computation)
(execute computation (make-environment))))) (execute computation (make-environment)))))
((_ make-environment run ((v d) . v*) n (p ...)) ((_ make-environment run ((v d) . v*) n (p ...))
(%define-computation-type make-environment run v* (+ n 1) (p ... (v d e #f n)))) (%define-computation-type make-environment run v* (+ n 1) (p ... (v d e #f n))))
((_ make-environment run ((v d "immutable") . v*) n (p ...)) ((_ make-environment run ((v d "immutable") . v*) n (p ...))
@ -101,58 +101,59 @@
(define (computation-environment-ref env var) (define (computation-environment-ref env var)
(if (predefined? var) (if (predefined? var)
(unbox (environment-cell env var)) (unbox (environment-cell env var))
(mapping-ref (environment-local env) (mapping-ref
var (environment-local env)
(lambda () var
(hash-table-ref/default (environment-global env) (lambda ()
var (hash-table-ref/default (environment-global env)
(environment-variable-default var))) var
unbox))) (environment-variable-default var)))
unbox)))
(define (computation-environment-update env . arg*) (define (computation-environment-update env . arg*)
(let ((new-env (vector-copy env))) (let ((new-env (vector-copy env)))
(let loop ((arg* arg*) (let loop ((arg* arg*)
(local (environment-local env))) (local (environment-local env)))
(if (null? arg*) (if (null? arg*)
(begin (begin
(environment-set-local! new-env local) (environment-set-local! new-env local)
new-env) new-env)
(let ((var (car arg*)) (let ((var (car arg*))
(val (cadr arg*))) (val (cadr arg*)))
(if (predefined? var) (if (predefined? var)
(begin (begin
(environment-cell-set! new-env var (box val)) (environment-cell-set! new-env var (box val))
(loop (cddr arg*) local)) (loop (cddr arg*) local))
(loop (cddr arg*) (mapping-set local var (box val))))))))) (loop (cddr arg*) (mapping-set local var (box val)))))))))
(define (computation-environment-update! env var val) (define (computation-environment-update! env var val)
(if (predefined? var) (if (predefined? var)
(set-box! (environment-cell env var) val) (set-box! (environment-cell env var) val)
(mapping-ref (environment-local env) (mapping-ref (environment-local env)
var var
(lambda () (lambda ()
(hash-table-set! (environment-global env) var val)) (hash-table-set! (environment-global env) var val))
(lambda (cell) (lambda (cell)
(set-box! cell val))))) (set-box! cell val)))))
(define (computation-environment-copy env) (define (computation-environment-copy env)
(let ((global (hash-table-copy (environment-global env) #t))) (let ((global (hash-table-copy (environment-global env) #t)))
(mapping-for-each (lambda (var cell) (mapping-for-each (lambda (var cell)
(hash-table-set! global var (unbox cell))) (hash-table-set! global var (unbox cell)))
(environment-local env)) (environment-local env))
(let ((new-env (make-vector (vector-length env)))) (let ((new-env (make-vector (vector-length env))))
(environment-set-global! new-env global) (environment-set-global! new-env global)
(environment-set-local! new-env (mapping variable-comparator)) (environment-set-local! new-env (mapping variable-comparator))
(do ((i (- (vector-length env) 1) (- i 1))) (do ((i (- (vector-length env) 1) (- i 1)))
((< i 2) ((< i 2)
new-env) new-env)
(vector-set! new-env i (box (unbox (vector-ref env i)))))))) (vector-set! new-env i (box (unbox (vector-ref env i))))))))
(define (execute computation env) (define (execute computation env)
(let ((coerce (if (procedure? computation) (let ((coerce (if (procedure? computation)
values values
(or (computation-environment-ref env default-computation) (or (computation-environment-ref env default-computation)
(error "not a computation" computation))))) (error "not a computation" computation)))))
((coerce computation) env))) ((coerce computation) env)))
(define (make-computation proc) (define (make-computation proc)
@ -168,25 +169,25 @@
(computation-each-in-list (cons a a*))) (computation-each-in-list (cons a a*)))
(define (computation-each-in-list a*) (define (computation-each-in-list a*)
(make-computation (make-computation
(lambda (compute) (lambda (compute)
(let loop ((a (car a*)) (a* (cdr a*))) (let loop ((a (car a*)) (a* (cdr a*)))
(if (null? a*) (if (null? a*)
(compute a) (compute a)
(begin (begin
(compute a) (compute a)
(loop (car a*) (cdr a*)))))))) (loop (car a*) (cdr a*))))))))
(define (computation-bind a . f*) (define (computation-bind a . f*)
(make-computation (make-computation
(lambda (compute) (lambda (compute)
(let loop ((a a) (f* f*)) (let loop ((a a) (f* f*))
(if (null? f*) (if (null? f*)
(compute a) (compute a)
(loop (call-with-values (loop (call-with-values
(lambda () (compute a)) (lambda () (compute a))
(car f*)) (car f*))
(cdr f*))))))) (cdr f*)))))))
(define (computation-ask) (define (computation-ask)
(lambda (env) (lambda (env)
@ -205,11 +206,12 @@
(syntax-rules () (syntax-rules ()
((_ () ((id var tmp) ...) expr ... computation) ((_ () ((id var tmp) ...) expr ... computation)
(let ((tmp var) ...) (let ((tmp var) ...)
(computation-bind (computation-ask) (computation-bind
(lambda (env) (computation-ask)
(let ((id (computation-environment-ref env tmp)) ...) (lambda (env)
expr ... (let ((id (computation-environment-ref env tmp)) ...)
computation))))) expr ...
computation)))))
((_ ((id var) . rest) (p ...) expr ... computation) ((_ ((id var) . rest) (p ...) expr ... computation)
(%fn rest (p ... (id var tmp)) expr ... computation)) (%fn rest (p ... (id var tmp)) expr ... computation))
((_ (id . rest) (p ...) expr ... computation) ((_ (id . rest) (p ...) expr ... computation)
@ -225,9 +227,9 @@
((_ () ((x u) ...) ((a b) ...)) ((_ () ((x u) ...) ((a b) ...))
(let ((u x) ... (b a) ...) (let ((u x) ... (b a) ...)
(computation-local (computation-local
(lambda (env) (lambda (env)
(computation-environment-update env u ...) ) (computation-environment-update env u ...) )
(computation-each b ...)))) (computation-each b ...))))
((_ ((var val) . rest) (p ...) () a* ...) ((_ ((var val) . rest) (p ...) () a* ...)
(%with rest (p ... (var u) (val v)) () a* ...)) (%with rest (p ... (var u) (val v)) () a* ...))
((_ () p* (q ...) a . a*) ((_ () p* (q ...) a . a*)
@ -242,10 +244,11 @@
(syntax-rules () (syntax-rules ()
((_ ((var u val v) ...)) ((_ ((var u val v) ...))
(let ((u var) ... (v val) ...) (let ((u var) ... (v val) ...)
(computation-bind (computation-ask) (computation-bind
(lambda (env) (computation-ask)
(computation-environment-update! env u v) ... (lambda (env)
(computation-pure (if #f #f)))))) (computation-environment-update! env u v) ...
(computation-pure (if #f #f))))))
((_ (var val) r ... (p ...)) ((_ (var val) r ... (p ...))
(%with! r ... (p ... (var u val v)))))) (%with! r ... (p ... (var u val v))))))
@ -254,24 +257,27 @@
(lambda (compute) (lambda (compute)
(let loop ((a a) (a* a*)) (let loop ((a a) (a* a*))
(if (null? a*) (if (null? a*)
(compute a) (compute a)
(begin (begin
(compute (computation-local (compute (computation-local
(lambda (env) (lambda (env)
(computation-environment-copy env)) (computation-environment-copy env))
a)) a))
(loop (car a*) (cdr a*)))))))) (loop (car a*) (cdr a*))))))))
(define (computation-bind/forked computation . proc*) (define (computation-bind/forked computation . proc*)
(apply computation-bind (apply computation-bind
(computation-local computation-environment-copy computation) (computation-local computation-environment-copy computation)
proc*)) proc*))
(define (computation-sequence fmt*) (define (computation-sequence fmt*)
(fold-right (lambda (fmt res) (fold-right
(computation-bind res (lambda (fmt res)
(lambda (vals) (computation-bind
(computation-bind fmt res
(lambda (val) (lambda (vals)
(computation-pure (cons val vals))))))) (computation-bind
(computation-pure '()) fmt*)) fmt
(lambda (val)
(computation-pure (cons val vals)))))))
(computation-pure '()) fmt*))

30
lib/srfi/165.sld
View file

@ -23,20 +23,20 @@
(define-library (srfi 165) (define-library (srfi 165)
(export make-computation-environment-variable (export make-computation-environment-variable
make-computation-environment computation-environment-ref make-computation-environment computation-environment-ref
computation-environment-update computation-environment-update
computation-environment-update! computation-environment-copy computation-environment-update! computation-environment-copy
make-computation computation-each computation-each-in-list make-computation computation-each computation-each-in-list
computation-pure computation-bind computation-sequence computation-pure computation-bind computation-sequence
computation-run computation-ask computation-local computation-run computation-ask computation-local
computation-fn computation-with computation-with! computation-fn computation-with computation-with!
computation-forked computation-bind/forked computation-forked computation-bind/forked
default-computation default-computation
define-computation-type) define-computation-type)
(import (scheme base) (import (scheme base)
(srfi 1) (srfi 1)
(srfi 111) (srfi 111)
(srfi 125) (srfi 125)
(srfi 128) (srfi 128)
(srfi 146)) (srfi 146))
(include "165.scm")) (include "165.scm"))