~ chicken-core (chicken-5) d8d2334fb2b23f83108eaf6c2c74e269c4f91096
commit d8d2334fb2b23f83108eaf6c2c74e269c4f91096
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Apr 16 18:50:14 2015 +1200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Apr 16 18:50:14 2015 +1200
Suffix mini-srfi-1 lset procedures to indicate that they use eq?
diff --git a/c-backend.scm b/c-backend.scm
index e81ab4df..7f269ebc 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -553,12 +553,12 @@
[direct (lambda-literal-direct ll)]
[allocated (lambda-literal-allocated ll)] )
(when (>= n small-parameter-limit)
- (set! large-signatures (lset-adjoin large-signatures (add1 n))) )
+ (set! large-signatures (lset-adjoin/eq? large-signatures (add1 n))))
(gen #t)
(for-each
(lambda (s)
(when (>= s small-parameter-limit)
- (set! large-signatures (lset-adjoin large-signatures (add1 s))) ) )
+ (set! large-signatures (lset-adjoin/eq? large-signatures (add1 s)))))
(lambda-literal-callee-signatures ll) )
(cond [(not (eq? 'toplevel id))
(gen "C_noret_decl(" id ")" #t)
@@ -654,8 +654,8 @@
(gen ");}") ]
[(or rest (> (lambda-literal-allocated ll) 0) (lambda-literal-external ll))
(if (and rest (not (eq? rest-mode 'none)))
- (set! nsr (lset-adjoin nsr argc))
- (set! ns (lset-adjoin ns argc)) ) ] ) ) ) )
+ (set! nsr (lset-adjoin/eq? nsr argc))
+ (set! ns (lset-adjoin/eq? ns argc)))]))))
lambda-table)
(for-each
(lambda (n)
diff --git a/core.scm b/core.scm
index afe0f49e..8d813491 100644
--- a/core.scm
+++ b/core.scm
@@ -656,7 +656,7 @@
(apply ##sys#require ids)
(##sys#hash-table-update!
file-requirements 'dynamic/syntax
- (cut lset-union <> ids)
+ (cut lset-union/eq? <> ids)
(lambda () ids) )
'(##core#undefined) ) )
@@ -1415,7 +1415,7 @@
(when (pair? us)
(##sys#hash-table-update!
file-requirements 'static
- (cut lset-union us <>)
+ (cut lset-union/eq? us <>)
(lambda () us))
(let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
(set! used-units (append used-units units)) ) ) ) )
@@ -1440,8 +1440,8 @@
(set! extended-bindings default-extended-bindings) ]
[else
(let ([syms (stripa (cdr spec))])
- (set! standard-bindings (lset-intersection syms default-standard-bindings))
- (set! extended-bindings (lset-intersection syms default-extended-bindings)) ) ] ) )
+ (set! standard-bindings (lset-intersection/eq? syms default-standard-bindings))
+ (set! extended-bindings (lset-intersection/eq? syms default-extended-bindings)))]))
((number-type)
(check-decl spec 1 1)
(set! number-type (strip (cadr spec))))
@@ -1491,14 +1491,14 @@
(if (null? (cddr spec))
(set! standard-bindings '())
(set! standard-bindings
- (lset-difference default-standard-bindings
- (stripa (cddr spec))))) ]
+ (lset-difference/eq? default-standard-bindings
+ (stripa (cddr spec)))))]
[(extended-bindings)
(if (null? (cddr spec))
(set! extended-bindings '())
(set! extended-bindings
- (lset-difference default-extended-bindings
- (stripa (cddr spec))) )) ]
+ (lset-difference/eq? default-extended-bindings
+ (stripa (cddr spec)))))]
[(inline)
(if (null? (cddr spec))
(set! inline-locally #f)
@@ -1511,8 +1511,8 @@
(set! extended-bindings '()) ]
[else
(let ([syms (stripa (cddr spec))])
- (set! standard-bindings (lset-difference default-standard-bindings syms))
- (set! extended-bindings (lset-difference default-extended-bindings syms)) ) ] ) ]
+ (set! standard-bindings (lset-difference/eq? default-standard-bindings syms))
+ (set! extended-bindings (lset-difference/eq? default-extended-bindings syms)))])]
((inline-global)
(set! enable-inline-files #t)
(when (pair? (cddr spec))
@@ -2296,12 +2296,12 @@
(define (test sym item) (db-get db sym item))
(define (register-customizable! var id)
- (set! customizable (lset-adjoin customizable var))
+ (set! customizable (lset-adjoin/eq? customizable var))
(db-put! db id 'customizable #t) )
(define (register-direct-call! id)
(set! direct-calls (add1 direct-calls))
- (set! direct-call-ids (lset-adjoin direct-call-ids id)) )
+ (set! direct-call-ids (lset-adjoin/eq? direct-call-ids id)))
;; Gather free-variable information:
;; (and: - register direct calls
@@ -2387,7 +2387,7 @@
(let ((c (delete-duplicates (gather (first subs) id vars) eq?)))
(db-put! db id 'closure-size (length c))
(db-put! db id 'captured-variables c)
- (lset-difference c locals vars)))))))
+ (lset-difference/eq? c locals vars)))))))
(else (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
@@ -2784,7 +2784,7 @@
((##core#call)
(let ((len (length (cdr subs))))
- (set! signatures (lset-adjoin signatures len))
+ (set! signatures (lset-adjoin/eq? signatures len))
(when (and (>= (length params) 3) (eq? here (third params)))
(set! looping (add1 looping)) )
(make-node class params (mapwalk subs e e-count here boxes)) ) )
diff --git a/csc.scm b/csc.scm
index 0b059420..f82d20f4 100644
--- a/csc.scm
+++ b/csc.scm
@@ -779,7 +779,7 @@ EOF
(set! link-options (append link-options (list arg))) ]
[(> (string-length arg) 2)
(let ([opts (cdr (string->list arg))])
- (if (null? (lset-difference opts short-options))
+ (if (null? (lset-difference/eq? opts short-options))
(set! rest
(append (map (lambda (o) (string-append "-" (string o))) opts) rest) )
(stop "invalid option `~A'" arg) ) ) ]
diff --git a/mini-srfi-1.scm b/mini-srfi-1.scm
index 30330e04..9ddef125 100644
--- a/mini-srfi-1.scm
+++ b/mini-srfi-1.scm
@@ -28,14 +28,14 @@
(declare
(unused take span drop partition split-at append-map every any cons* concatenate delete
first second third fourth alist-cons delete-duplicates fifth
- filter filter-map unzip1 last list-index lset-adjoin lset-difference
- lset-union lset-intersection list-tabulate lset<= lset= length+ find find-tail
- iota make-list posq posv)
+ filter filter-map unzip1 last list-index lset-adjoin/eq? lset-difference/eq?
+ lset-union/eq? lset-intersection/eq? list-tabulate lset<=/eq? lset=/eq? length+
+ find find-tail iota make-list posq posv)
(hide take span drop partition split-at append-map every any cons* concatenate delete
first second third fourth alist-cons delete-duplicates fifth
- filter filter-map unzip1 last list-index lset-adjoin lset-difference
- lset-union lset-intersection list-tabulate lset<= lset= length+ find find-tail
- iota make-list posq posv))
+ filter filter-map unzip1 last list-index lset-adjoin/eq? lset-difference/eq?
+ lset-union/eq? lset-intersection/eq? list-tabulate lset<=/eq? lset=/eq? length+
+ find find-tail iota make-list posq posv))
(define (partition pred lst)
@@ -149,20 +149,20 @@
((pred (car lst)) i)
(else (loop (fx+ i 1) (cdr lst))))))
-(define (lset-adjoin lst . vals)
+(define (lset-adjoin/eq? lst . vals)
(let loop ((vals vals) (lst lst))
(cond ((null? vals) lst)
((memq (car vals) lst) (loop (cdr vals) lst))
(else (loop (cdr vals) (cons (car vals) lst))))))
-(define (lset-difference ls . lss)
+(define (lset-difference/eq? ls . lss)
(foldl
(lambda (ls lst)
(filter (lambda (x) (not (memq x lst))) ls))
ls
lss))
-(define (lset-union ls . lss)
+(define (lset-union/eq? ls . lss)
(foldl
(lambda (ls lst)
(foldl
@@ -173,7 +173,7 @@
ls lst))
'() lss))
-(define (lset-intersection ls1 . lss)
+(define (lset-intersection/eq? ls1 . lss)
(filter (lambda (x)
(every (lambda (lis) (memq x lis)) lss))
ls1))
@@ -184,10 +184,10 @@
'()
(cons (proc i) (loop (fx+ i 1))))))
-(define (lset<= s1 s2)
+(define (lset<=/eq? s1 s2)
(every (lambda (s) (memq s s2)) s1))
-(define (lset= s1 s2)+
+(define (lset=/eq? s1 s2)
(and (eq? (length s1) (length s2))
(every (lambda (s) (memq s s2)) s1)))
diff --git a/optimizer.scm b/optimizer.scm
index 7df97da7..6f36b051 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -214,7 +214,7 @@
(cond ((not ok)
(unless odirty (set! dirty #f))
(set! broken-constant-nodes
- (lset-adjoin broken-constant-nodes n1))
+ (lset-adjoin/eq? broken-constant-nodes n1))
n1)
(else
(touch)
@@ -885,7 +885,7 @@
(alist-cons
id
(filter-map
- (lambda (g2) (and (not (eq? g2 g)) (lset<= (cdr g2) deps) (car g2)))
+ (lambda (g2) (and (not (eq? g2 g)) (lset<=/eq? (cdr g2) deps) (car g2)))
groups)
cgraph) ) ) )
groups)
@@ -1463,7 +1463,7 @@
(set! hoistable '())
(set! allocated 0)
(and (rec n #f #f env)
- (lset= closures (delete kvar inner-ks)) ) ) )
+ (lset=/eq? closures (delete kvar inner-ks)))))
(define (transform n fnvar ks hoistable destn allocated)
(if (pair? hoistable)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index d4c808b4..a68dc210 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1266,8 +1266,8 @@
(merge-result-types rtypes1 rtypes2))))
(car ts)
(cdr ts))))
- ((lset= '(true false) ts) 'boolean)
- ((lset= '(fixnum float) ts) 'number)
+ ((lset=/eq? '(true false) ts) 'boolean)
+ ((lset=/eq? '(fixnum float) ts) 'number)
(else
(let* ((ts (append-map
(lambda (t)
@@ -1327,7 +1327,7 @@
(else t)))
((assq t typeenv) =>
(lambda (e)
- (set! used (lset-adjoin used t))
+ (set! used (lset-adjoin/eq? used t))
(cdr e)))
(else t)))))
(let ((t2 (simplify t)))
diff --git a/support.scm b/support.scm
index db1e5fc3..d6fcf95d 100644
--- a/support.scm
+++ b/support.scm
@@ -137,7 +137,7 @@
(define (test-mode mode set)
(if (symbol? mode)
(memq mode set)
- (pair? (lset-intersection mode set))))
+ (pair? (lset-intersection/eq? mode set))))
(cond ((test-mode mode debugging-chicken)
(let ((txt (with-output-to-string thunk)))
(display txt)
@@ -1294,12 +1294,12 @@
((##core#variable)
(let ((var (first params)))
(unless (memq var e)
- (set! vars (lset-adjoin vars var))
+ (set! vars (lset-adjoin/eq? vars var))
(unless (variable-visible? var block-compilation)
- (set! hvars (lset-adjoin hvars var))))))
+ (set! hvars (lset-adjoin/eq? hvars var))))))
((set!)
(let ((var (first params)))
- (unless (memq var e) (set! vars (lset-adjoin vars var)))
+ (unless (memq var e) (set! vars (lset-adjoin/eq? vars var)))
(walk (car subs) e) ) )
((let)
(walk (first subs) e)
Trap