suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: tweaks for mpairs

Browse Source
This commit is contained in:
Matthew Flatt 2020-12-14 15:10:38 -07:00
parent e90c2a2138
commit f76b814dd7
4 changed files with 33 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
racket/src/cs/rumble/equal.ss
View File

@ -99,6 +99,17 @@
(let ([ctx (deeper-context ctx)])
(lambda (a b)
(equal? a b ctx)))))))]
[(mpair? a)
(and (mpair? b)
(or (check-union-find ctx a b)
(if eql?
(and (eql? (mcar a) (mcar b))
(eql? (mcdr a) (mcdr b))
#t)
(let ([ctx (deeper-context ctx)])
(and
(equal? (mcar a) (mcar b) ctx)
(equal? (mcdr a) (mcdr b) ctx))))))]
[(record? a)
(and (record? b)
;; Check for `prop:impersonator-of`

10
racket/src/cs/rumble/hash-code.ss
View File

@ -1,4 +1,4 @@
;;; Parts from "newhash.ss" in Chez Scheme's implementation
;;; Parts from "newhash.ss" in Chez Scheme's imp<lementation
;;; newhash.ss
;;; Copyright 1984-2016 Cisco Systems, Inc.
@ -160,6 +160,10 @@
(let-values ([(hc0 burn0) (equal-hash-loop x burn 0)])
hc0)))))])
(values hc burn)))]
[(mpair? x)
(let-values ([(hc0 burn) (equal-hash-loop (mcar x) (fx+ burn 2) 0)])
(let ([hc (fx+/wraparound (mix-hash-code hc) (fx+/wraparound hc0 5))])
(equal-hash-loop (mcdr x) burn hc)))]
[(and (#%$record? x) (#%$record-hash-procedure x))
=> (lambda (rec-hash)
(let ([burn (fx+ burn 2)])
@ -213,6 +217,10 @@
(let-values ([(hc0 burn0) (equal-secondary-hash-loop x burn 0)])
hc0)))))])
(values hc burn)))]
[(mpair? x)
(let-values ([(hc0 burn) (equal-secondary-hash-loop (mcar x) (fx+ burn 2) 0)])
(let ([hc (fx+/wraparound (mix-hash-code hc) hc0)])
(equal-secondary-hash-loop (mcdr x) burn hc)))]
[(and (#%$record? x)
(or (struct-property-ref 'secondary-hash (#%$record-type-descriptor x) #f)
;; to use default hash proc as default secondary hash proc:

18
racket/src/cs/rumble/inline.ss
View File

@ -3,7 +3,9 @@
(define-syntax (define-inline stx)
(syntax-case stx ()
[(_ (orig-id arg ...) guard op)
[(_ proto guard op)
#'(define-inline proto guard op #3%$app/no-inline)]
[(_ (orig-id arg ...) guard op orig-app)
(with-syntax ([(tmp ...) (generate-temporaries #'(arg ...))]
[id (datum->syntax #'orig-id
(#%string->symbol
@ -15,7 +17,7 @@
#'(let ([arg tmp] ...)
(if guard
op
(#3%$app/no-inline orig-id arg ...)))]
(orig-app orig-id arg ...)))]
[(_ . args)
#'(orig-id . args)]
[_ #'orig-id])))]))
@ -62,19 +64,23 @@
(define-inline (mcar p)
(mpair? p)
(unsafe-mcar p))
(unsafe-mcar p)
|#%app/no-return|)
(define-inline (mcdr p)
(mpair? p)
(unsafe-mcdr p))
(unsafe-mcdr p)
|#%app/no-return|)
(define-inline (set-mcar! p v)
(mpair? p)
(unsafe-set-mcar! p v))
(unsafe-set-mcar! p v)
|#%app/no-return|)
(define-inline (set-mcdr! p v)
(mpair? p)
(unsafe-set-mcdr! p v))
(unsafe-set-mcdr! p v)
|#%app/no-return|)
(define-inline (unsafe-struct-ref s i)
(not (impersonator? s))

2
racket/src/schemify/left-to-right.rkt
View File

@ -129,4 +129,4 @@
`(call-with-values (lambda () ,rhs)
(case-lambda
[,ids ,body]
[args (raise-binding-result-arity-error ,(length ids) args)]))])])]))
[args (#%app/no-return raise-binding-result-arity-error ,(length ids) args)]))])])]))