Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-12 15:27:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Moving record types to (scheme base)

Browse source
This commit is contained in:
Justin Ethier 2016-04-28 03:45:38 -04:00
parent 4a34ef49a1
commit cbb15c98dc
2 changed files with 124 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
docs/Scheme-Language-Compliance.md
View file

@ -28,7 +28,7 @@ Section | Status | Comments
5.2 Import declarations | Partial |
5.3 Variable definitions | Partial | `define-values` is not implemented yet.
5.4 Syntax definitions | Yes |
5.5 Record-type definitions | Yes | Located in the `(srfi 9)` library.
5.5 Record-type definitions | Yes |
5.6 Libraries | Partial | Support is "good enough" but need to make it more robust
5.7 The REPL | Yes |
6.1 Equivalence predicates | Yes | `eqv?` is not implemented, it is just an alias to `eq?`

124
scheme/base.sld
View file

@ -18,7 +18,8 @@
;delete
;delete-duplicates
;; TODO: possibly relocating here in the future
;define-record-type
define-record-type
record?
; register-simple-type
; make-type-predicate
; make-constructor
@ -1358,4 +1359,125 @@
(if test
(begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...)))))
;; Record-type definitions
(define record-marker (list 'record-marker))
(define (register-simple-type name parent 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)
(lambda (obj)
(and (vector? obj)
(equal? (vector-ref obj 0) record-marker)
(equal? (vector-ref obj 1) name))))
(define (make-constructor make name)
(lambda ()
(let* ((field-tags (vector-ref name 2))
(field-values (make-vector (length field-tags) #f))
(new (make-vector 3 #f))
)
(vector-set! new 0 record-marker)
(vector-set! new 1 name)
(vector-set! new 2 field-values)
new)))
(define (type-slot-offset name sym)
(let ((field-tags (vector-ref name 2)))
(list-index2 sym field-tags)))
(define (slot-set! name obj idx val)
(let ((vec obj)) ;; TODO: get actual slots from obj
(vector-set! (vector-ref vec 2) idx val)))
(define (make-getter sym name idx)
(lambda (obj)
(vector-ref (vector-ref obj 2) idx)))
(define (make-setter sym name idx)
(lambda (obj val)
(vector-set! (vector-ref obj 2) idx val)))
(define (record? obj)
(and (vector? obj)
(> (vector-length obj) 0)
(equal? record-marker (vector-ref obj 0))))
(define-syntax define-record-type
(er-macro-transformer
(lambda (expr rename compare)
(let* ((name+parent (cadr expr))
(name (if (pair? name+parent) (car name+parent) name+parent))
(parent (and (pair? name+parent) (cadr name+parent)))
(name-str (symbol->string name)) ;(identifier->symbol name)))
(procs (cddr expr))
(make (caar procs))
(make-fields (cdar procs))
(pred (cadr procs))
(fields (cddr procs))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let))
(_register (rename 'register-simple-type))
(_slot-set! (rename 'slot-set!))
(_type_slot_offset (rename 'type-slot-offset)))
;; catch a common mistake
(if (eq? name make)
(error "same binding for record rtd and constructor" name))
`(,(rename 'begin)
;; type
(,_define ,name (,_register
,name ;,name-str
,parent
',(map car fields)))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,pred ;(symbol->string pred) ;(identifier->symbol pred))
,name))
;; fields
,@(map (lambda (f)
(and (pair? f) (pair? (cdr f))
`(,_define ,(cadr f)
(,(rename 'make-getter)
,(symbol->string
(cadr f)
;(identifier->symbol (cadr f))
)
,name
(,_type_slot_offset ,name ',(car f))))))
fields)
,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (pair? (cddr f))
`(,_define ,(car (cddr f))
(,(rename 'make-setter)
,(symbol->string
(car (cddr f))
;(identifier->symbol (car (cddr f)))
)
,name
(,_type_slot_offset ,name ',(car f))))))
fields)
;; constructor
(,_define ,make
,(let lp ((ls make-fields) (sets '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(symbol->string make) ;(identifier->symbol make))
,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)))))))))
)))))
))