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

181
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,93 +1280,102 @@
[(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 ([(stype ...) (values slot-type ...)] (let-values ([(super-pointer super-tags super-types super-offsets
[(types) (list stype ...)] super->list* list*->super)
[(offsets) (compute-offsets types)] (cstruct-info
[(offset ...) (apply values offsets)]) first-type
(define-values (super-pointer super-tags super-types super-offsets (lambda () (values #f '() #f #f #f #f)))])
super->list* list*->super)
(cstruct-info first-type
(lambda () (values #f '() #f #f #f #f))))
(define-cpointer-type _TYPE super-pointer) (define-cpointer-type _TYPE super-pointer)
(define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types))) ;; these makes it possible to use recursive pointer definitions
(define all-tags (cons TYPE-tag super-tags)) (define _TYPE-pointer _TYPE)
(define-values (all-types all-offsets) (define _TYPE-pointer/null _TYPE/null)
(if (and has-super? super-types super-offsets) (let*-values ([(stype ...) (values slot-type ...)]
(values (append super-types (cdr types)) [(types) (list stype ...)]
(append super-offsets (cdr offsets))) [(offsets) (compute-offsets types)]
(values types offsets))) [(offset ...) (apply values offsets)])
(define (TYPE-SLOT x) (define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types)))
(unless (TYPE? x) (raise-type-error 'TYPE-SLOT struct-string x)) (define all-tags (cons TYPE-tag super-tags))
(ptr-ref x stype 'abs offset)) (define-values (all-types all-offsets)
... (if (and has-super? super-types super-offsets)
(define (set-TYPE-SLOT! x slot) (values (append super-types (cdr types))
(unless (TYPE? x) (append super-offsets (cdr offsets)))
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot)) (values types offsets)))
(ptr-set! x stype 'abs offset slot)) (define (TYPE-SLOT x)
... (unless (TYPE? x)
(define make-TYPE (raise-type-error 'TYPE-SLOT struct-string x))
(if (and has-super? super-types super-offsets) (ptr-ref x stype 'abs offset))
;; init using all slots ...
(lambda vals (define (set-TYPE-SLOT! x slot)
(if (= (length vals) (length all-types)) (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*)]) (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 ([(ptr tags types offsets T->list* list*->T) (length all-types) (length vals) vals)]))
(cstruct-info (define (TYPE->list x)
type (unless (TYPE? x)
(lambda () (values #f '() #f #f #f #f)))]) (raise-type-error 'TYPE-list struct-string x))
(ptr-set! block type 'abs ofs (map (lambda (type ofs) (ptr-ref x type 'abs ofs))
(if list*->T (list*->T value) value)))) all-types all-offsets))
all-types all-offsets vals) (define (TYPE->list* x)
block)] (unless (TYPE? x)
[else (error '_TYPE "expecting ~s values, got ~s: ~e" (raise-type-error 'TYPE-list struct-string x))
(length all-types) (length vals) vals)])) (map (lambda (type ofs)
(define (TYPE->list x) (let-values
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x)) ([(v) (ptr-ref x type 'abs ofs)]
(map (lambda (type ofs) (ptr-ref x type 'abs ofs)) [(ptr tags types offsets T->list* list*->T)
all-types all-offsets)) (cstruct-info
(define (TYPE->list* x) type
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x)) (lambda () (values #f '() #f #f #f #f)))])
(map (lambda (type ofs) (if T->list* (T->list* v) v)))
(let-values ([(v) (ptr-ref x type 'abs ofs)] all-types all-offsets))
[(ptr tags types offsets T->list* list*->T) (cstruct-info
(cstruct-info _TYPE* 'set!
type _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
(lambda () (values #f '() #f #f #f #f)))]) (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
(if T->list* (T->list* v) v))) make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
all-types all-offsets)) TYPE-SLOT ... set-TYPE-SLOT! ...))))))
(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! ...)))))
(define (identifiers? stx) (define (identifiers? stx)
(andmap identifier? (syntax->list stx))) (andmap identifier? (syntax->list stx)))
(define (_-identifier? stx) (define (_-identifier? stx)