made it possible for a cstruct to have pointers to itself
original commit: edb73f0a7d29e4e0f1c0ba12bbb876e87dd2f335
This commit is contained in:
Eli Barzilay
parent
4703212d8d
commit
a1a0262c65
|
|
@ -1249,10 +1249,12 @@
|
|||
(datum->syntax-object
|
||||
_TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
|
||||
(define (ids name-func)
|
||||
(map (lambda (s stx)
|
||||
(map (lambda (s)
|
||||
(datum->syntax-object
|
||||
stx (string->symbol (apply string-append (name-func s))) stx))
|
||||
slot-names (syntax->list slot-names-stx)))
|
||||
_TYPE-stx
|
||||
(string->symbol (apply string-append (name-func s)))
|
||||
_TYPE-stx))
|
||||
slot-names))
|
||||
(with-syntax
|
||||
([first-type (let ([xs (syntax->list slot-types-stx)])
|
||||
(and (pair? xs) (car xs)))]
|
||||
|
|
@ -1263,6 +1265,8 @@
|
|||
[(slot-type ...) slot-types-stx]
|
||||
[_TYPE _TYPE-stx]
|
||||
[_TYPE-pointer (id "_"name"-pointer")]
|
||||
[_TYPE-pointer/null (id "_"name"-pointer/null")]
|
||||
[_TYPE/null (id "_"name"/null")]
|
||||
[_TYPE* (id "_"name"*")]
|
||||
[TYPE? (id name"?")]
|
||||
[make-TYPE (id "make-"name)]
|
||||
|
|
@ -1276,93 +1280,102 @@
|
|||
[(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
|
||||
[(offset ...) (generate-temporaries
|
||||
(ids (lambda (s) `(,s"-offset"))))])
|
||||
#'(define-values (_TYPE _TYPE-pointer TYPE? TYPE-tag make-TYPE
|
||||
list->TYPE list*->TYPE TYPE->list TYPE->list*
|
||||
#'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
|
||||
make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
|
||||
TYPE-SLOT ... set-TYPE-SLOT! ...)
|
||||
(let*-values ([(stype ...) (values slot-type ...)]
|
||||
[(types) (list stype ...)]
|
||||
[(offsets) (compute-offsets types)]
|
||||
[(offset ...) (apply values offsets)])
|
||||
(define-values (super-pointer super-tags super-types super-offsets
|
||||
super->list* list*->super)
|
||||
(cstruct-info first-type
|
||||
(lambda () (values #f '() #f #f #f #f))))
|
||||
(let-values ([(super-pointer super-tags super-types super-offsets
|
||||
super->list* list*->super)
|
||||
(cstruct-info
|
||||
first-type
|
||||
(lambda () (values #f '() #f #f #f #f)))])
|
||||
(define-cpointer-type _TYPE super-pointer)
|
||||
(define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types)))
|
||||
(define all-tags (cons TYPE-tag super-tags))
|
||||
(define-values (all-types all-offsets)
|
||||
(if (and has-super? super-types super-offsets)
|
||||
(values (append super-types (cdr types))
|
||||
(append super-offsets (cdr offsets)))
|
||||
(values types offsets)))
|
||||
(define (TYPE-SLOT x)
|
||||
(unless (TYPE? x) (raise-type-error 'TYPE-SLOT struct-string x))
|
||||
(ptr-ref x stype 'abs offset))
|
||||
...
|
||||
(define (set-TYPE-SLOT! x slot)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
|
||||
(ptr-set! x stype 'abs offset slot))
|
||||
...
|
||||
(define make-TYPE
|
||||
(if (and has-super? super-types super-offsets)
|
||||
;; init using all slots
|
||||
(lambda vals
|
||||
(if (= (length vals) (length all-types))
|
||||
;; these makes it possible to use recursive pointer definitions
|
||||
(define _TYPE-pointer _TYPE)
|
||||
(define _TYPE-pointer/null _TYPE/null)
|
||||
(let*-values ([(stype ...) (values slot-type ...)]
|
||||
[(types) (list stype ...)]
|
||||
[(offsets) (compute-offsets types)]
|
||||
[(offset ...) (apply values offsets)])
|
||||
(define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types)))
|
||||
(define all-tags (cons TYPE-tag super-tags))
|
||||
(define-values (all-types all-offsets)
|
||||
(if (and has-super? super-types super-offsets)
|
||||
(values (append super-types (cdr types))
|
||||
(append super-offsets (cdr offsets)))
|
||||
(values types offsets)))
|
||||
(define (TYPE-SLOT x)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'TYPE-SLOT struct-string x))
|
||||
(ptr-ref x stype 'abs offset))
|
||||
...
|
||||
(define (set-TYPE-SLOT! x slot)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
|
||||
(ptr-set! x stype 'abs offset slot))
|
||||
...
|
||||
(define make-TYPE
|
||||
(if (and has-super? super-types super-offsets)
|
||||
;; init using all slots
|
||||
(lambda vals
|
||||
(if (= (length vals) (length all-types))
|
||||
(let ([block (malloc _TYPE*)])
|
||||
(set-cpointer-tag! block all-tags)
|
||||
(for-each (lambda (type ofs value)
|
||||
(ptr-set! block type 'abs ofs value))
|
||||
all-types all-offsets vals)
|
||||
block)
|
||||
(error '_TYPE "expecting ~s values, got ~s: ~e"
|
||||
(length all-types) (length vals) vals)))
|
||||
;; normal initializer
|
||||
(lambda (slot ...)
|
||||
(let ([block (malloc _TYPE*)])
|
||||
(set-cpointer-tag! block all-tags)
|
||||
(for-each (lambda (type ofs value)
|
||||
(ptr-set! block type 'abs ofs value))
|
||||
all-types all-offsets vals)
|
||||
block)
|
||||
(error '_TYPE "expecting ~s values, got ~s: ~e"
|
||||
(length all-types) (length vals) vals)))
|
||||
;; normal initializer
|
||||
(lambda (slot ...)
|
||||
(ptr-set! block stype 'abs offset slot)
|
||||
...
|
||||
block))))
|
||||
(define (list->TYPE vals) (apply make-TYPE vals))
|
||||
(define (list*->TYPE vals)
|
||||
(cond
|
||||
[(TYPE? vals) vals]
|
||||
[(= (length vals) (length all-types))
|
||||
(let ([block (malloc _TYPE*)])
|
||||
(set-cpointer-tag! block all-tags)
|
||||
(ptr-set! block stype 'abs offset slot)
|
||||
...
|
||||
block))))
|
||||
(define (list->TYPE vals) (apply make-TYPE vals))
|
||||
(define (list*->TYPE vals)
|
||||
(cond
|
||||
[(TYPE? vals) vals]
|
||||
[(= (length vals) (length all-types))
|
||||
(let ([block (malloc _TYPE*)])
|
||||
(set-cpointer-tag! block all-tags)
|
||||
(for-each
|
||||
(lambda (type ofs value)
|
||||
(let-values ([(ptr tags types offsets T->list* list*->T)
|
||||
(cstruct-info
|
||||
type
|
||||
(lambda () (values #f '() #f #f #f #f)))])
|
||||
(ptr-set! block type 'abs ofs
|
||||
(if list*->T (list*->T value) value))))
|
||||
all-types all-offsets vals)
|
||||
block)]
|
||||
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
|
||||
(length all-types) (length vals) vals)]))
|
||||
(define (TYPE->list x)
|
||||
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x))
|
||||
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
|
||||
all-types all-offsets))
|
||||
(define (TYPE->list* x)
|
||||
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x))
|
||||
(map (lambda (type ofs)
|
||||
(let-values ([(v) (ptr-ref x type 'abs ofs)]
|
||||
[(ptr tags types offsets T->list* list*->T)
|
||||
(cstruct-info
|
||||
type
|
||||
(lambda () (values #f '() #f #f #f #f)))])
|
||||
(if T->list* (T->list* v) v)))
|
||||
all-types all-offsets))
|
||||
(cstruct-info
|
||||
_TYPE* 'set!
|
||||
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
|
||||
(values _TYPE* _TYPE TYPE? TYPE-tag make-TYPE
|
||||
list->TYPE list*->TYPE TYPE->list TYPE->list*
|
||||
TYPE-SLOT ... set-TYPE-SLOT! ...)))))
|
||||
(for-each
|
||||
(lambda (type ofs value)
|
||||
(let-values
|
||||
([(ptr tags types offsets T->list* list*->T)
|
||||
(cstruct-info
|
||||
type
|
||||
(lambda () (values #f '() #f #f #f #f)))])
|
||||
(ptr-set! block type 'abs ofs
|
||||
(if list*->T (list*->T value) value))))
|
||||
all-types all-offsets vals)
|
||||
block)]
|
||||
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
|
||||
(length all-types) (length vals) vals)]))
|
||||
(define (TYPE->list x)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'TYPE-list struct-string x))
|
||||
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
|
||||
all-types all-offsets))
|
||||
(define (TYPE->list* x)
|
||||
(unless (TYPE? x)
|
||||
(raise-type-error 'TYPE-list struct-string x))
|
||||
(map (lambda (type ofs)
|
||||
(let-values
|
||||
([(v) (ptr-ref x type 'abs ofs)]
|
||||
[(ptr tags types offsets T->list* list*->T)
|
||||
(cstruct-info
|
||||
type
|
||||
(lambda () (values #f '() #f #f #f #f)))])
|
||||
(if T->list* (T->list* v) v)))
|
||||
all-types all-offsets))
|
||||
(cstruct-info
|
||||
_TYPE* 'set!
|
||||
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
|
||||
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
|
||||
make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
|
||||
TYPE-SLOT ... set-TYPE-SLOT! ...))))))
|
||||
(define (identifiers? stx)
|
||||
(andmap identifier? (syntax->list stx)))
|
||||
(define (_-identifier? stx)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user