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

made it possible for a cstruct to have pointers to itself

Browse Source 
original commit: edb73f0a7d29e4e0f1c0ba12bbb876e87dd2f335
This commit is contained in:
Eli Barzilay 2005-04-09 20:58:28 +00:00
parent 4703212d8d
commit a1a0262c65
1 changed files with 97 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mzlib/foreign.ss
View File

@ -1249,10 +1249,12 @@
(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))
(define (ids name-func) (define (ids name-func)
(map (lambda (s stx) (map (lambda (s)
(datum->syntax-object (datum->syntax-object
stx (string->symbol (apply string-append (name-func s))) stx)) _TYPE-stx
slot-names (syntax->list slot-names-stx))) (string->symbol (apply string-append (name-func s)))
_TYPE-stx))
slot-names))
(with-syntax (with-syntax
([first-type (let ([xs (syntax->list slot-types-stx)]) ([first-type (let ([xs (syntax->list slot-types-stx)])
(and (pair? xs) (car xs)))] (and (pair? xs) (car xs)))]
@ -1263,6 +1265,8 @@
[(slot-type ...) slot-types-stx] [(slot-type ...) slot-types-stx]
[_TYPE _TYPE-stx] [_TYPE _TYPE-stx]
[_TYPE-pointer (id "_"name"-pointer")] [_TYPE-pointer (id "_"name"-pointer")]
[_TYPE-pointer/null (id "_"name"-pointer/null")]
[_TYPE/null (id "_"name"/null")]
[_TYPE* (id "_"name"*")] [_TYPE* (id "_"name"*")]
[TYPE? (id name"?")] [TYPE? (id name"?")]
[make-TYPE (id "make-"name)] [make-TYPE (id "make-"name)]
@ -1276,18 +1280,22 @@
[(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? TYPE-tag make-TYPE #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
list->TYPE list*->TYPE TYPE->list TYPE->list* make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
TYPE-SLOT ... set-TYPE-SLOT! ...) TYPE-SLOT ... set-TYPE-SLOT! ...)
(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)
;; 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 ...)] (let*-values ([(stype ...) (values slot-type ...)]
[(types) (list stype ...)] [(types) (list stype ...)]
[(offsets) (compute-offsets types)] [(offsets) (compute-offsets types)]
[(offset ...) (apply values offsets)]) [(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))))
(define-cpointer-type _TYPE super-pointer)
(define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types))) (define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types)))
(define all-tags (cons TYPE-tag super-tags)) (define all-tags (cons TYPE-tag super-tags))
(define-values (all-types all-offsets) (define-values (all-types all-offsets)
@ -1296,7 +1304,8 @@
(append super-offsets (cdr offsets))) (append super-offsets (cdr offsets)))
(values types offsets))) (values types offsets)))
(define (TYPE-SLOT x) (define (TYPE-SLOT x)
(unless (TYPE? x) (raise-type-error 'TYPE-SLOT struct-string x)) (unless (TYPE? x)
(raise-type-error 'TYPE-SLOT struct-string x))
(ptr-ref x stype 'abs offset)) (ptr-ref x stype 'abs offset))
... ...
(define (set-TYPE-SLOT! x slot) (define (set-TYPE-SLOT! x slot)
@ -1333,7 +1342,8 @@
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(for-each (for-each
(lambda (type ofs value) (lambda (type ofs value)
(let-values ([(ptr tags types offsets T->list* list*->T) (let-values
([(ptr tags types offsets T->list* list*->T)
(cstruct-info (cstruct-info
type type
(lambda () (values #f '() #f #f #f #f)))]) (lambda () (values #f '() #f #f #f #f)))])
@ -1344,13 +1354,16 @@
[else (error '_TYPE "expecting ~s values, got ~s: ~e" [else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)])) (length all-types) (length vals) vals)]))
(define (TYPE->list x) (define (TYPE->list x)
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x)) (unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (ptr-ref x type 'abs ofs)) (map (lambda (type ofs) (ptr-ref x type 'abs ofs))
all-types all-offsets)) all-types all-offsets))
(define (TYPE->list* x) (define (TYPE->list* x)
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x)) (unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (map (lambda (type ofs)
(let-values ([(v) (ptr-ref x type 'abs ofs)] (let-values
([(v) (ptr-ref x type 'abs ofs)]
[(ptr tags types offsets T->list* list*->T) [(ptr tags types offsets T->list* list*->T)
(cstruct-info (cstruct-info
type type
@ -1360,9 +1373,9 @@
(cstruct-info (cstruct-info
_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 TYPE? TYPE-tag make-TYPE (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
list->TYPE list*->TYPE TYPE->list TYPE->list* make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
TYPE-SLOT ... set-TYPE-SLOT! ...))))) 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)