suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix self-referential cstructs

Browse Source 
svn: r924
This commit is contained in:
Eli Barzilay 2005-09-27 09:20:21 +00:00
parent 30a1c9e69d
commit 6efbcbbba3
1 changed files with 100 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/mzlib/foreign.ss
View File

@ -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,14 +1300,19 @@
[(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"))))])
(with-syntax ([get-super-info
;; the 1st-type might be a pointer to this type
(if (or (module-identifier=? 1st-type #'_TYPE-pointer/null)
(module-identifier=? 1st-type #'_TYPE-pointer))
#'(values #f '() #f #f #f #f)
#`(cstruct-info #,1st-type
(lambda () (values #f '() #f #f #f #f))))])
#'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list* make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
TYPE-SLOT ... set-TYPE-SLOT! ...) list->TYPE list*->TYPE TYPE->list TYPE->list*)
(let-values ([(super-pointer super-tags super-types super-offsets (let-values ([(super-pointer super-tags super-types super-offsets
super->list* list*->super) super->list* list*->super)
(cstruct-info get-super-info])
first-type
(lambda () (values #f '() #f #f #f #f)))])
(define-cpointer-type _TYPE super-pointer) (define-cpointer-type _TYPE super-pointer)
;; these makes it possible to use recursive pointer definitions ;; these makes it possible to use recursive pointer definitions
(define _TYPE-pointer _TYPE) (define _TYPE-pointer _TYPE)
@ -1394,8 +1399,8 @@
_TYPE* 'set! _TYPE* 'set!
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list* make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
TYPE-SLOT ... set-TYPE-SLOT! ...)))))) list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
(define (identifiers? stx) (define (identifiers? stx)
(andmap identifier? (syntax->list stx))) (andmap identifier? (syntax->list stx)))
(define (_-identifier? stx) (define (_-identifier? stx)