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)))))
(define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
(syntax->list slot-names-stx)))
(define 1st-type
(let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs))))
(define (id . strings)
(datum->syntax-object
_TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
@ -1276,9 +1278,7 @@
_TYPE-stx))
slot-names))
(with-syntax
([first-type (let ([xs (syntax->list slot-types-stx)])
(and (pair? xs) (car xs)))]
[has-super? has-super?]
([has-super? has-super?]
[name-string name]
[struct-string (format "struct:~a" name)]
[(slot ...) slot-names-stx]
@ -1300,14 +1300,19 @@
[(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
[(offset ...) (generate-temporaries
(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
make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
TYPE-SLOT ... set-TYPE-SLOT! ...)
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*)
(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)))])
get-super-info])
(define-cpointer-type _TYPE super-pointer)
;; these makes it possible to use recursive pointer definitions
(define _TYPE-pointer _TYPE)
@ -1394,8 +1399,8 @@
_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! ...))))))
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
(define (identifiers? stx)
(andmap identifier? (syntax->list stx)))
(define (_-identifier? stx)