Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-16 09:17:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Issue #402 - Type check record type getter/setter

Browse source
This commit is contained in:
Justin Ethier 2020-08-17 18:01:43 -04:00
parent 3ec4ff352a
commit ed167c71c1
1 changed files with 12 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
scheme/base.sld
View file

@ -1969,13 +1969,7 @@
;; Record-type definitions ;; Record-type definitions
(define record-marker (list 'record-marker)) (define record-marker (list 'record-marker))
(define (register-simple-type name parent field-tags) (define (register-simple-type name parent field-tags)
(vector record-marker name field-tags) (vector record-marker name field-tags))
;(let ((new (make-vector 3 #f)))
; (vector-set! new 0 record-marker)
; (vector-set! new 1 name)
; (vector-set! new 2 field-tags)
; new)
)
(define (make-type-predicate pred name) (define (make-type-predicate pred name)
(lambda (obj) (lambda (obj)
(and (vector? obj) (and (vector? obj)
@ -2009,10 +2003,14 @@
(vector-ref (vector-ref obj 2) idx))) (vector-ref (vector-ref obj 2) idx)))
(define (make-getter sym name idx) (define (make-getter sym name idx)
(lambda (obj) (lambda (obj)
(vector-ref (vector-ref obj 2) idx))) (if (eq? (vector-ref obj 1) name)
(vector-ref (vector-ref obj 2) idx)
(error "Invalid type" obj "expected" name))))
(define (make-setter sym name idx) (define (make-setter sym name idx)
(lambda (obj val) (lambda (obj val)
(vector-set! (vector-ref obj 2) idx val))) (if (eq? (vector-ref obj 1) name)
(vector-set! (vector-ref obj 2) idx val)
(error "Invalid type" obj "expected" name))))
;; Find index of element in list, or #f if not found ;; Find index of element in list, or #f if not found
(define _list-index (define _list-index
@ -2037,7 +2035,6 @@
(let* ((name+parent (cadr expr)) (let* ((name+parent (cadr expr))
(name (if (pair? name+parent) (car name+parent) name+parent)) (name (if (pair? name+parent) (car name+parent) name+parent))
(parent (and (pair? name+parent) (cadr name+parent))) (parent (and (pair? name+parent) (cadr name+parent)))
(name-str (symbol->string name)) ;(identifier->symbol name)))
(procs (cddr expr)) (procs (cddr expr))
(make (caar procs)) (make (caar procs))
(make-fields (cdar procs)) (make-fields (cdar procs))
@ -2055,11 +2052,11 @@
`(,(rename 'begin) `(,(rename 'begin)
;; type ;; type
(,_define ,name (,_register (,_define ,name (,_register
,name-str (quote ,name)
,parent ,parent
',(map car fields))) ',(map car fields)))
;; predicate ;; predicate
(,_define ,pred (,(rename 'make-type-predicate) 0 ,name)) (,_define ,pred (,(rename 'make-type-predicate) 0 (quote ,name)))
;; fields ;; fields
,@(map (lambda (f) ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (and (pair? f) (pair? (cdr f))
@ -2069,7 +2066,7 @@
(cadr f) (cadr f)
;(identifier->symbol (cadr f)) ;(identifier->symbol (cadr f))
) )
,name (quote ,name)
(,_type_slot_offset ,name ',(car f)))))) (,_type_slot_offset ,name ',(car f))))))
fields) fields)
,@(map (lambda (f) ,@(map (lambda (f)
@ -2080,7 +2077,7 @@
(car (cddr f)) (car (cddr f))
;(identifier->symbol (car (cddr f))) ;(identifier->symbol (car (cddr f)))
) )
,name (quote ,name)
(,_type_slot_offset ,name ',(car f)))))) (,_type_slot_offset ,name ',(car f))))))
fields) fields)
;; constructor ;; constructor
@ -2095,7 +2092,7 @@
(,_lambda ,make-fields (,_lambda ,make-fields
(,(rename 'vector) (,(rename 'vector)
',record-marker ',record-marker
,name (quote ,name)
(,(rename 'vector) (,(rename 'vector)
,@make-fields)))) ,@make-fields))))
))))) )))))