fix self-referential cstructs
svn: r924
This commit is contained in:
Eli Barzilay
parent
30a1c9e69d
commit
6efbcbbba3
|
|
@ -1265,6 +1265,8 @@
|
||||||
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
|
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
|
||||||
(define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
|
(define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
|
||||||
(syntax->list slot-names-stx)))
|
(syntax->list slot-names-stx)))
|
||||||
|
(define 1st-type
|
||||||
|
(let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs))))
|
||||||
(define (id . strings)
|
(define (id . strings)
|
||||||
(datum->syntax-object
|
(datum->syntax-object
|
||||||
_TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
|
_TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
|
||||||
|
|
@ -1276,9 +1278,7 @@
|
||||||
_TYPE-stx))
|
_TYPE-stx))
|
||||||
slot-names))
|
slot-names))
|
||||||
(with-syntax
|
(with-syntax
|
||||||
([first-type (let ([xs (syntax->list slot-types-stx)])
|
([has-super? has-super?]
|
||||||
(and (pair? xs) (car xs)))]
|
|
||||||
[has-super? has-super?]
|
|
||||||
[name-string name]
|
[name-string name]
|
||||||
[struct-string (format "struct:~a" name)]
|
[struct-string (format "struct:~a" name)]
|
||||||
[(slot ...) slot-names-stx]
|
[(slot ...) slot-names-stx]
|
||||||
|
|
@ -1300,102 +1300,107 @@
|
||||||
[(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
|
[(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
|
||||||
[(offset ...) (generate-temporaries
|
[(offset ...) (generate-temporaries
|
||||||
(ids (lambda (s) `(,s"-offset"))))])
|
(ids (lambda (s) `(,s"-offset"))))])
|
||||||
#'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
|
(with-syntax ([get-super-info
|
||||||
make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
|
;; the 1st-type might be a pointer to this type
|
||||||
TYPE-SLOT ... set-TYPE-SLOT! ...)
|
(if (or (module-identifier=? 1st-type #'_TYPE-pointer/null)
|
||||||
(let-values ([(super-pointer super-tags super-types super-offsets
|
(module-identifier=? 1st-type #'_TYPE-pointer))
|
||||||
super->list* list*->super)
|
#'(values #f '() #f #f #f #f)
|
||||||
(cstruct-info
|
#`(cstruct-info #,1st-type
|
||||||
first-type
|
(lambda () (values #f '() #f #f #f #f))))])
|
||||||
(lambda () (values #f '() #f #f #f #f)))])
|
#'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
|
||||||
(define-cpointer-type _TYPE super-pointer)
|
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
|
||||||
;; these makes it possible to use recursive pointer definitions
|
list->TYPE list*->TYPE TYPE->list TYPE->list*)
|
||||||
(define _TYPE-pointer _TYPE)
|
(let-values ([(super-pointer super-tags super-types super-offsets
|
||||||
(define _TYPE-pointer/null _TYPE/null)
|
super->list* list*->super)
|
||||||
(let*-values ([(stype ...) (values slot-type ...)]
|
get-super-info])
|
||||||
[(types) (list stype ...)]
|
(define-cpointer-type _TYPE super-pointer)
|
||||||
[(offsets) (compute-offsets types)]
|
;; these makes it possible to use recursive pointer definitions
|
||||||
[(offset ...) (apply values offsets)])
|
(define _TYPE-pointer _TYPE)
|
||||||
(define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types)))
|
(define _TYPE-pointer/null _TYPE/null)
|
||||||
(define all-tags (cons TYPE-tag super-tags))
|
(let*-values ([(stype ...) (values slot-type ...)]
|
||||||
(define-values (all-types all-offsets)
|
[(types) (list stype ...)]
|
||||||
(if (and has-super? super-types super-offsets)
|
[(offsets) (compute-offsets types)]
|
||||||
(values (append super-types (cdr types))
|
[(offset ...) (apply values offsets)])
|
||||||
(append super-offsets (cdr offsets)))
|
(define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types)))
|
||||||
(values types offsets)))
|
(define all-tags (cons TYPE-tag super-tags))
|
||||||
(define (TYPE-SLOT x)
|
(define-values (all-types all-offsets)
|
||||||
(unless (TYPE? x)
|
(if (and has-super? super-types super-offsets)
|
||||||
(raise-type-error 'TYPE-SLOT struct-string x))
|
(values (append super-types (cdr types))
|
||||||
(ptr-ref x stype 'abs offset))
|
(append super-offsets (cdr offsets)))
|
||||||
...
|
(values types offsets)))
|
||||||
(define (set-TYPE-SLOT! x slot)
|
(define (TYPE-SLOT x)
|
||||||
(unless (TYPE? x)
|
(unless (TYPE? x)
|
||||||
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
|
(raise-type-error 'TYPE-SLOT struct-string x))
|
||||||
(ptr-set! x stype 'abs offset slot))
|
(ptr-ref x stype 'abs offset))
|
||||||
...
|
...
|
||||||
(define make-TYPE
|
(define (set-TYPE-SLOT! x slot)
|
||||||
(if (and has-super? super-types super-offsets)
|
(unless (TYPE? x)
|
||||||
;; init using all slots
|
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
|
||||||
(lambda vals
|
(ptr-set! x stype 'abs offset slot))
|
||||||
(if (= (length vals) (length all-types))
|
...
|
||||||
|
(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*)])
|
(let ([block (malloc _TYPE*)])
|
||||||
(set-cpointer-tag! block all-tags)
|
(set-cpointer-tag! block all-tags)
|
||||||
(for-each (lambda (type ofs value)
|
(ptr-set! block stype 'abs offset slot)
|
||||||
(ptr-set! block type 'abs ofs value))
|
...
|
||||||
all-types all-offsets vals)
|
block))))
|
||||||
block)
|
(define (list->TYPE vals) (apply make-TYPE vals))
|
||||||
(error '_TYPE "expecting ~s values, got ~s: ~e"
|
(define (list*->TYPE vals)
|
||||||
(length all-types) (length vals) vals)))
|
(cond
|
||||||
;; normal initializer
|
[(TYPE? vals) vals]
|
||||||
(lambda (slot ...)
|
[(= (length vals) (length all-types))
|
||||||
(let ([block (malloc _TYPE*)])
|
(let ([block (malloc _TYPE*)])
|
||||||
(set-cpointer-tag! block all-tags)
|
(set-cpointer-tag! block all-tags)
|
||||||
(ptr-set! block stype 'abs offset slot)
|
(for-each
|
||||||
...
|
(lambda (type ofs value)
|
||||||
block))))
|
(let-values
|
||||||
(define (list->TYPE vals) (apply make-TYPE vals))
|
([(ptr tags types offsets T->list* list*->T)
|
||||||
(define (list*->TYPE vals)
|
(cstruct-info
|
||||||
(cond
|
type
|
||||||
[(TYPE? vals) vals]
|
(lambda () (values #f '() #f #f #f #f)))])
|
||||||
[(= (length vals) (length all-types))
|
(ptr-set! block type 'abs ofs
|
||||||
(let ([block (malloc _TYPE*)])
|
(if list*->T (list*->T value) value))))
|
||||||
(set-cpointer-tag! block all-tags)
|
all-types all-offsets vals)
|
||||||
(for-each
|
block)]
|
||||||
(lambda (type ofs value)
|
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
|
||||||
(let-values
|
(length all-types) (length vals) vals)]))
|
||||||
([(ptr tags types offsets T->list* list*->T)
|
(define (TYPE->list x)
|
||||||
(cstruct-info
|
(unless (TYPE? x)
|
||||||
type
|
(raise-type-error 'TYPE-list struct-string x))
|
||||||
(lambda () (values #f '() #f #f #f #f)))])
|
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
|
||||||
(ptr-set! block type 'abs ofs
|
all-types all-offsets))
|
||||||
(if list*->T (list*->T value) value))))
|
(define (TYPE->list* x)
|
||||||
all-types all-offsets vals)
|
(unless (TYPE? x)
|
||||||
block)]
|
(raise-type-error 'TYPE-list struct-string x))
|
||||||
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
|
(map (lambda (type ofs)
|
||||||
(length all-types) (length vals) vals)]))
|
(let-values
|
||||||
(define (TYPE->list x)
|
([(v) (ptr-ref x type 'abs ofs)]
|
||||||
(unless (TYPE? x)
|
[(ptr tags types offsets T->list* list*->T)
|
||||||
(raise-type-error 'TYPE-list struct-string x))
|
(cstruct-info
|
||||||
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
|
type
|
||||||
all-types all-offsets))
|
(lambda () (values #f '() #f #f #f #f)))])
|
||||||
(define (TYPE->list* x)
|
(if T->list* (T->list* v) v)))
|
||||||
(unless (TYPE? x)
|
all-types all-offsets))
|
||||||
(raise-type-error 'TYPE-list struct-string x))
|
(cstruct-info
|
||||||
(map (lambda (type ofs)
|
_TYPE* 'set!
|
||||||
(let-values
|
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
|
||||||
([(v) (ptr-ref x type 'abs ofs)]
|
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
|
||||||
[(ptr tags types offsets T->list* list*->T)
|
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
|
||||||
(cstruct-info
|
list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
|
||||||
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)
|
(define (identifiers? stx)
|
||||||
(andmap identifier? (syntax->list stx)))
|
(andmap identifier? (syntax->list stx)))
|
||||||
(define (_-identifier? stx)
|
(define (_-identifier? stx)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user