Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-25 04:55:04 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Faster initialization of objects create via define-record-type

Browse source
This commit is contained in:
Justin Ethier 2019-02-27 14:31:14 -05:00
parent 0f0beb024c
commit 8772c5355b
2 changed files with 19 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
CHANGELOG.md
View file

@ -2,6 +2,10 @@
## 0.9.10 - TBD ## 0.9.10 - TBD
Features
- Faster initialization of objects create via `define-record-type`.
## 0.9.9 - February 19, 2019 ## 0.9.9 - February 19, 2019
Bug Fixes Bug Fixes

46
scheme/base.sld
View file

@ -23,6 +23,7 @@
register-simple-type register-simple-type
make-type-predicate make-type-predicate
make-constructor make-constructor
make-constructor/args
make-getter make-getter
make-setter make-setter
slot-ref slot-ref
@ -1831,18 +1832,18 @@
(equal? (vector-ref obj 0) record-marker) (equal? (vector-ref obj 0) record-marker)
(equal? (vector-ref obj 1) name)))) (equal? (vector-ref obj 1) name))))
(define (make-constructor make name) (define (make-constructor make name)
(lambda () (lambda args
(let* ((field-tags (vector-ref name 2)) (let* ((field-tags (vector-ref name 2))
(field-values (make-vector (length field-tags) #f)) (field-values (make-vector (length field-tags) #f))
; (new (make-vector 3 #f))
) )
; (vector-set! new 0 record-marker) (vector record-marker name field-values))))
; (vector-set! new 1 name) (define (make-constructor/args make name)
; (vector-set! new 2 field-values) (lambda args
; new (let* ((field-tags (vector-ref name 2))
(vector record-marker name field-values) (field-values (list->vector args)))
) (when (not (equal? (length field-tags) (length args)))
)); (error "invalid number of arguments passed to record type constructor" args))
(vector record-marker name field-values))))
(define (type-slot-offset name sym) (define (type-slot-offset name sym)
(let ((field-tags (vector-ref name 2))) (let ((field-tags (vector-ref name 2)))
(_list-index sym field-tags))) (_list-index sym field-tags)))
@ -1940,27 +1941,10 @@
fields) fields)
;; constructor ;; constructor
(,_define ,make (,_define ,make
,(let lp ((ls make-fields) (sets '())) (,_let ((%make (,(rename 'make-constructor/args)
(cond ,(symbol->string make) ;(identifier->symbol make))
((null? ls) ,name)))
`(,_let ((%make (,(rename 'make-constructor) (,_lambda ,make-fields
,(symbol->string make) ;(identifier->symbol make)) (%make ,@make-fields))))
,name)))
(,_lambda ,make-fields
(,_let ((res (%make)))
,@sets
res))))
(else
(let ((field (assq (car ls) fields)))
(cond
((not field)
(error "unknown record field in constructor" (car ls)))
((pair? (cddr field))
(lp (cdr ls)
(cons `(,(car (cddr field)) res ,(car ls)) sets)))
(else
(lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
sets)))))))))
))))) )))))
)) ))