~ chicken-core (chicken-5) e5cde6ed0a67efa0ac07de3fc3a0a540bebde8a9
commit e5cde6ed0a67efa0ac07de3fc3a0a540bebde8a9
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jun 3 22:09:26 2023 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Jun 3 22:09:26 2023 +0200
Add new weak pair procedures to types database, and a NEWS entry
We don't want to completely overhaul the entire type system to support
weak pairs and the overloaded pair-or-weak-pair accessors which might
now return broken-weak-pointer values. Also, the pair? predicate
could no longer be a proper predicate if we added weak pairs as
distinct types.
Instead, we accept that weak pairs are not typically used that much
and therefore it's not worth making it into a real "core" type. With
this realisation, we can simply make the type of "(weak-cons a b)"
return "(pair (or a bwp) b)" - which is *technically* incorrect (the
bwp is replaced at GC time) but it should work because the GC might
as well happen right after (or even *during*?!) the weak-cons call.
The new bwp object, however, *is* its own distinct type, so we do need
to add it to the scrutinizer (and the lfa2 pass).
NOTE: This requires first running "make boot-chicken" and use the
resulting chicken-boot binary to compile the sources.
While we're at it, teach the non-scrutiny builtin rewriting rules in
c-platform.scm about the new procedures.
diff --git a/NEWS b/NEWS
index 6ecbbad2..b3a3b20a 100644
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,7 @@
the first non-runtime option or after "-:", whichever comes first.
- Core libraries
+ - Added weak pairs to (chicken base), with similar behaviour to Chez Scheme.
- Added "locative-index", kindly contributed by John Croisant.
- Added "fp*+" (fused multiply-add) to "chicken.flonum" module
(suggested by Christian Himpe).
diff --git a/c-platform.scm b/c-platform.scm
index fdbb1b83..335009bc 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -173,6 +173,8 @@
chicken.base#equal=? chicken.base#exact-integer?
chicken.base#flush-output
+ chicken.base#weak-cons chicken.base#weak-pair? chicken.base#bwp-object?
+
chicken.base#identity chicken.base#o chicken.base#atom?
chicken.base#alist-ref chicken.base#rassoc
@@ -539,6 +541,7 @@
(rewrite 'srfi-4#f64vector? 2 1 "C_i_f64vectorp" #t)
(rewrite 'scheme#pair? 2 1 "C_i_pairp" #t)
(rewrite '##sys#pair? 2 1 "C_i_pairp" #t)
+(rewrite 'chicken.base#weak-pair? 2 1 "C_i_weak_pairp" #t)
(rewrite 'scheme#procedure? 2 1 "C_i_closurep" #t)
(rewrite 'chicken.base#port? 2 1 "C_i_portp" #t)
(rewrite 'scheme#boolean? 2 1 "C_booleanp" #t)
@@ -566,6 +569,7 @@
(rewrite 'scheme#inexact? 2 1 "C_u_i_inexactp" #f)
(rewrite 'scheme#list? 2 1 "C_i_listp" #t)
(rewrite 'scheme#eof-object? 2 1 "C_eofp" #t)
+(rewrite 'chicken.base#bwp-object? 2 1 "C_bwpp" #t)
(rewrite 'scheme#string-ref 2 2 "C_subchar" #f)
(rewrite 'scheme#string-ref 2 2 "C_i_string_ref" #t)
(rewrite 'scheme#string-set! 2 3 "C_setsubchar" #f)
@@ -949,6 +953,7 @@
(rewrite 'scheme#cons 16 2 "C_a_i_cons" #t 3)
(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
+(rewrite 'chicken.base#weak-cons 16 2 "C_a_i_weak_cons" #t 3)
(rewrite 'scheme#list 16 #f "C_a_i_list" #t '(0 3) #t)
(rewrite '##sys#list 16 #f "C_a_i_list" #t '(0 3))
(rewrite 'scheme#vector 16 #f "C_a_i_vector" #t #t #t)
diff --git a/lfa2.scm b/lfa2.scm
index 38ed4da2..54fef531 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -255,6 +255,8 @@
((list? lit) 'list)
((pair? lit) 'pair)
((eof-object? lit) 'eof)
+ ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
+ ((##core#inline "C_bwpp" lit) #;(bwp-object? lit) 'bwp)
((vector? lit) 'vector)
((and (not (##sys#immediate? lit)) (##sys#generic-structure? lit))
`(struct ,(##sys#slot lit 0)))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 4204470f..cdf6f205 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -88,7 +88,7 @@
; | (deprecated NAME)
; VALUE = string | symbol | keyword | char | number |
; boolean | true | false |
-; null | eof | blob | pointer | port | locative | fixnum |
+; null | eof | bwp | blob | pointer | port | locative | fixnum |
; float | bignum | ratnum | cplxnum | integer | pointer-vector
; BASIC = * | list | pair | procedure | vector | undefined | noreturn | values
; COMPLEX = (pair TYPE TYPE)
@@ -133,7 +133,7 @@
(define-constant +maximal-complex-object-constructor-result-type-length+ 256)
(define-constant value-types
- '(string symbol keyword char null boolean true false blob eof
+ '(string symbol keyword char null boolean true false blob eof bwp
fixnum float number integer bignum ratnum cplxnum
pointer-vector port pointer locative))
@@ -172,7 +172,7 @@
((or) (every type-always-immediate? (cdr t)))
((forall) (type-always-immediate? (third t)))
(else #f)))
- ((memq t '(eof null fixnum char boolean undefined)) #t)
+ ((memq t '(eof bwp null fixnum char boolean undefined)) #t)
(else #f)))
(define (scrutinize node db complain specialize strict block-compilation)
@@ -213,6 +213,8 @@
(simplify-type
`(pair ,(constant-result (car lit)) ,(constant-result (cdr lit)))))
((eof-object? lit) 'eof)
+ ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
+ ((##core#inline "C_bwpp" lit) #;(bwp-object? lit) 'bwp)
((vector? lit)
(simplify-type
`(vector ,@(map constant-result (vector->list lit)))))
diff --git a/types.db b/types.db
index acd9d80b..0e48c434 100644
--- a/types.db
+++ b/types.db
@@ -148,11 +148,11 @@
(scheme#cddddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cddddr ((pair * (pair * (pair * (pair * a))))) a)))
(scheme#set-car! (#(procedure #:enforce) scheme#set-car! (pair *) undefined)
- ((pair (or fixnum char boolean eof null undefined)) (##sys#setislot #(1) '0 #(2)))
+ ((pair (or fixnum char boolean eof bwp null undefined)) (##sys#setislot #(1) '0 #(2)))
((pair *) (##sys#setslot #(1) '0 #(2))))
(scheme#set-cdr! (#(procedure #:enforce) scheme#set-cdr! (pair *) undefined)
- ((pair (or fixnum char boolean eof null undefined)) (##sys#setislot #(1) '1 #(2)))
+ ((pair (or fixnum char boolean eof bwp null undefined)) (##sys#setislot #(1) '1 #(2)))
((pair *) (##sys#setslot #(1) '1 #(2))))
(scheme#null? (#(procedure #:pure #:predicate null) scheme#null? (*) boolean))
@@ -875,6 +875,11 @@
(chicken.base#exact-integer-sqrt (#(procedure #:clean #:enforce #:foldable) chicken.base#exact-integer-sqrt (integer) integer integer)
((integer) (##sys#exact-integer-sqrt #(1))))
+(chicken.base#weak-cons (forall (a b) (#(procedure #:pure) chicken.base#weak-cons (a b) (pair (or a bwp) b))))
+;; NOTE: This is *not* a #:predicate, as we don't want to introduce a completely new weak-pair type
+(chicken.base#weak-pair? (#(procedure #:pure) chicken.base#weak-pair? (*) boolean))
+(chicken.base#bwp-object? (#(procedure #:pure #:predicate bwp) chicken.base#bwp-object? (*) boolean))
+
(chicken.base#fixnum? (#(procedure #:pure #:predicate fixnum) chicken.base#fixnum? (*) boolean))
(chicken.base#flonum? (#(procedure #:pure #:predicate float) chicken.base#flonum? (*) boolean))
(chicken.base#bignum? (#(procedure #:pure #:predicate bignum) chicken.base#bignum? (*) boolean))
@@ -939,8 +944,8 @@
(chicken.base#error (procedure chicken.base#error (* #!rest) noreturn))
(chicken.base#equal=? (#(procedure #:clean #:foldable) chicken.base#equal=? (* *) boolean)
((fixnum fixnum) (scheme#eq? #(1) #(2)))
- (((or symbol keyword char eof null undefined) *) (scheme#eq? #(1) #(2)))
- ((* (or symbol keyword char eof null undefined)) (scheme#eq? #(1) #(2)))
+ (((or symbol keyword char eof bwp null undefined) *) (scheme#eq? #(1) #(2)))
+ ((* (or symbol keyword char eof bwp null undefined)) (scheme#eq? #(1) #(2)))
((number number) (scheme#= #(1) #(2))))
(chicken.base#emergency-exit (procedure chicken.base#emergency-exit (#!optional fixnum) noreturn))
Trap