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

Revert "SRFI 160 vector= differs from SRFI 133 in not taking an eq predicate (issue #674)"

Browse source 
This reverts commit 340c5aa2a8.
This commit is contained in:
Alex Shinn 2020-07-31 15:08:59 +09:00
parent 340c5aa2a8
commit b7ffc4e700
7 changed files with 35 additions and 171 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
RELEASE
View file

@ -1 +1 @@
fluorine
oxygen

2
VERSION
View file

@ -1 +1 @@
0.9.0
0.8.0

5
lib/chibi/ast.scm
View file

@ -69,12 +69,9 @@
(define (get-rename id lam renames)
(let ((ls (assq lam renames)))
(let ((res (if (not ls)
(if (not ls)
(identifier->symbol id)
(cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id))))))
(if (eq? 'p-ls (identifier->symbol id))
(begin (write `(rename ,id => ,res)) (newline)))
res)))
(define (map* f ls)
(cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls))))

5
lib/chibi/match-test.sld
View file

@ -231,10 +231,7 @@
sum
(loop rest sum)))))
'(test "match-letrec" '(1 1)
(match-letrec (((x y) (list 1 (lambda () (list x x))))) (y)))
(test "match-letrec" '(2 1 1 2)
'(test "match-letrec" '(2 1 1 2)
(match-letrec (((x y) (list 1 (lambda () (list a x))))
((a b) (list 2 (lambda () (list x a)))))
(append (y) (b))))

147
lib/chibi/match/match.scm
View file

@ -943,6 +943,14 @@
((_ loop ((var init) ...) . body)
(match-named-let loop () ((var init) ...) . body))))
;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec}
;;> matches and binds the variables with all match variables in scope.
(define-syntax match-letrec
(syntax-rules ()
((_ ((var value) ...) . body)
(match-let/helper letrec () () ((var value) ...) . body))))
(define-syntax match-let/helper
(syntax-rules ()
((_ let ((var expr) ...) () () . body)
@ -982,145 +990,6 @@
((_ ((pat expr) . rest) . body)
(match expr (pat (match-let* rest . body))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Challenge stage - unhygienic insertion.
(define-syntax extract?
(syntax-rules ()
((_ symb body _cont-t _cont-f)
(letrec-syntax
((tr
(syntax-rules (symb); Found our ’symb’ -- exit to the continuation cont-t
((_ x symb tail (cont-head symb-l . cont-args) cont-false)
(cont-head (x . symb-l) . cont-args))
((_ d (x . y) tail . rest) ; if body is a composite form,
(tr x x (y . tail) . rest)) ; look inside
((_ d1 d2 () cont-t (cont-head symb-l . cont-args)) ; ’symb’ had not occurred -- exit to cont-f
(cont-head (symb . symb-l) . cont-args))
((_ d1 d2 (x . y) . rest)
(tr x x y . rest)))))
(tr body body () _cont-t _cont-f)))))
(define-syntax extract
(syntax-rules ()
((_ symb body cont)
(extract? symb body cont cont))))
(define-syntax extract*
(syntax-rules ()
((_ (symb) body cont) ; only one id: use extract to do the job
(extract symb body cont))
((_ _symbs _body _cont)
(letrec-syntax
((ex-aux ; extract id-by-id
(syntax-rules ()
((_ found-symbs () body cont)
(reverse () found-symbs cont))
((_ found-symbs (symb . symb-others) body cont)
(extract symb body (ex-aux found-symbs symb-others body cont)))))
(reverse ; reverse the list of extracted ids
(syntax-rules () ; to match the order of SYMB-L
((_ res () (cont-head () . cont-args))
(cont-head res . cont-args))
((_ res (x . tail) cont)
(reverse (x . res) tail cont)))))
(ex-aux () _symbs _body _cont)))))
(define-syntax mylet
(syntax-rules ()
((_ ((_var _init)) _body)
(letrec-syntax
((doit
(syntax-rules ()
((_ (mylet-symb mfoo-symb foo-symb) ((var init)) body)
(let ((var init))
(make-mfoo mfoo-symb foo-symb
(letrec-syntax
((mylet-symb
(syntax-rules ()
((_ ((var_ init_)) body_)
(extract* (mylet-symb mfoo-symb foo-symb)
(var_ body_)
(doit () ((var_ init_)) body_)))
)))
body)))))))
(extract* (mylet mfoo foo) (_var _body)
(doit () ((_var _init)) _body))))))
;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec}
;;> matches and binds the variables with all match variables in scope.
(define-syntax match-letrec
(syntax-rules ()
((_ ((pat val) ...) . body)
(match-letrec-one (pat ...) (((pat val) ...) . body) ()))))
;; 1: extract all ids
(define-syntax match-letrec-one
(syntax-rules ()
((_ (pat . rest) expr ((id tmp) ...))
(match-extract-vars pat (match-letrec-one rest expr) (id ...) ((id tmp) ...)))
((_ () expr ((id tmp) ...))
(let () ; (tmp '??) ...
(match-letrec-two expr () ((id tmp) ...))))))
;; 2: rewrite ids
(define-syntax match-letrec-two
(syntax-rules ()
((_ (() . body) ((var2 val2) ...) ((id tmp) ...))
;; we know the ids, their tmp names, and the renamed patterns
;; with the tmp names - expand to the classic letrec pattern of
;; let+set!:
(let ((id '?) ...)
(match-let ((var2 val2) ...)
(set! id tmp) ...
. body)))
((_ (((var val) . rest) . body) ((var2 val2) ...) ids)
(match-rewrite
var
ids
(match-letrec-two-step (rest . body) ((var2 val2) ...) ids val)))))
(define-syntax match-letrec-two-step
(syntax-rules ()
((_ next (rewrites ...) ids val var)
(match-letrec-two next (rewrites ... (var val)) ids))))
;; rewrite a list of vars in a nested structure
;; calls k on the rewritten structure
(define-syntax match-rewrite
(syntax-rules ()
((match-rewrite var () (k ...))
(k ... var))
((match-rewrite var ((id tmp) . rest) k)
(mylet ((id tmp)) ))))
'(define-syntax match-rewrite
(syntax-rules ()
((match-rewrite (p . q) ids k)
(match-rewrite p ids (match-rewrite2 q ids (match-cons k))))
((match-rewrite () ids (k ...))
(k ... ()))
((match-rewrite p ((id tmp) ...) (k ...))
(letrec-syntax
((k2
(syntax-rules ()
((k2 res) (k ... res))))
(rewrite
(syntax-rules (id ...)
((rewrite id) (k2 tmp)) ...
((rewrite other) (k2 p)))))
(rewrite p)))))
(define-syntax match-rewrite2
(syntax-rules ()
((match-rewrite2 q ids (k ...) p)
(match-rewrite q ids (k ... p)))))
(define-syntax match-cons
(syntax-rules ()
((match-cons (k ...) p q)
(k ... (p . q)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Otherwise COND-EXPANDed bits.

12
lib/srfi/160/test.sld
View file

@ -31,12 +31,12 @@
(test-group "uvectors/predicates"
(test #f (u32vector-empty? '#u32(0)))
(test-assert (u32vector-empty? '#u32()))
(test-assert (u32vector= '#u32(0 1 2 3) '#u32(0 1 2 3)))
(test #t (u32vector= '#u32(0 1 2 3) '#u32(0 1 2 3)))
(test #f (u32vector= '#u32(1 2 3 4 5) '#u32(1 2 3 4)))
(test-assert (u32vector=))
(test-assert (u32vector= '#u32(0)))
(test-assert (u32vector= (u32vector 0) (u32vector 0)))
(test-assert (u32vector= eq? '#u32(0 1 2 3) '#u32(0 1 2 3)))
(test #t (u32vector= eq? '#u32(0 1 2 3) '#u32(0 1 2 3)))
(test #f (u32vector= = '#u32(1 2 3 4 5) '#u32(1 2 3 4)))
(test-assert (u32vector= eq?))
(test-assert (u32vector= eq? '#u32(0)))
(test-assert (u32vector= equal? (u32vector 0) (u32vector 0)))
)
(test-group "uvectors/iteration"

21
lib/srfi/160/uvector.scm
View file

@ -2,20 +2,21 @@
(define (vector-empty? vec)
(zero? (uvector-length vec)))
(define (vector= . vecs)
(let lp1 ((ls vecs))
(or (null? ls)
(null? (cdr ls))
(let* ((v1 (car ls))
(v2 (cadr ls))
(define (vector= eq . o)
(cond
((null? o) #t)
((null? (cdr o)) #t)
(else
(and (let* ((v1 (car o))
(v2 (cadr o))
(len (uvector-length v1)))
(and (= len (uvector-length v2))
(let lp2 ((i 0))
(let lp ((i 0))
(or (>= i len)
(and (= (uvector-ref v1 i)
(and (eq (uvector-ref v1 i)
(uvector-ref v2 i))
(lp2 (+ i 1)))))
(lp1 (cdr ls)))))))
(lp (+ i 1)))))))
(apply vector= eq (cdr o))))))
(define (list->uvector ls)
(let ((res (make-uvector (length ls))))