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

Made a list*->struct and back that work with nested structs as nested lists

Browse Source 
original commit: 4d6dcbf5480bf75ce517717bd8402db3380b9401
This commit is contained in:
Eli Barzilay 2004-11-07 11:12:47 +00:00
parent 1cc971770a
commit 674e53ebb5
1 changed files with 48 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/mzlib/foreign.ss
View File

@ -1217,8 +1217,9 @@
[TYPE? (id name"?")]
[make-TYPE (id "make-"name)]
[list->TYPE (id "list->"name)]
[list*->TYPE (id "list*->"name)]
[TYPE->list (id name"->list")]
[TYPE->C (id name"->C")]
[TYPE->list* (id name"->list*")]
[TYPE-tag (id name"-tag")]
[(stype ...) (ids (lambda (s) `(,name"-",s"-type")))]
[(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))]
@ -1226,13 +1227,16 @@
[(offset ...) (generate-temporaries
(ids (lambda (s) `(,s"-offset"))))])
#'(define-values (_TYPE _TYPE-pointer TYPE? TYPE-tag make-TYPE
list->TYPE TYPE->list TYPE-SLOT ... set-TYPE-SLOT! ...)
list->TYPE list*->TYPE TYPE->list TYPE->list*
TYPE-SLOT ... set-TYPE-SLOT! ...)
(let*-values ([(stype ...) (values slot-type ...)]
[(types) (list stype ...)]
[(offsets) (compute-offsets types)]
[(offset ...) (apply values offsets)])
(define-values (super-pointer super-tags super-types super-offsets)
(cstruct-info first-type (lambda () (values #f '() #f #f))))
(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 all-tags (cons TYPE-tag super-tags))
@ -1253,16 +1257,16 @@
(define make-TYPE
(if (and has-super? super-types super-offsets)
;; init using all slots
(lambda values
(if (= (length values) (length all-types))
(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 values)
all-types all-offsets vals)
block)
(error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length values) values)))
(length all-types) (length vals) vals)))
;; normal initializer
(lambda (slot ...)
(let ([block (malloc _TYPE*)])
@ -1270,19 +1274,44 @@
(ptr-set! block stype 'abs offset slot)
...
block))))
(define (list->TYPE l) (apply make-TYPE l))
(define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals)
(cond
[(TYPE? vals) vals]
[(= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(for-each
(lambda (type ofs value)
(let-values ([(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(ptr-set! block type 'abs ofs
(if list*->T (list*->T value) value))))
all-types all-offsets vals)
block)]
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)]))
(define (TYPE->list x)
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x))
(let loop ([x x] [types all-types] [offsets all-offsets])
(map (lambda (typ ofs)
(let-values ([(v) (ptr-ref x typ 'abs ofs)]
[(ptr tags types offsets)
(cstruct-info
typ (lambda () (values #f '() #f #f)))])
(if (and types offsets) (loop v types offsets) v)))
types offsets)))
(cstruct-info _TYPE* 'set! _TYPE all-tags all-types all-offsets)
(values _TYPE* _TYPE TYPE? TYPE-tag make-TYPE list->TYPE TYPE->list
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
all-types all-offsets))
(define (TYPE->list* x)
(unless (TYPE? x) (raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs)
(let-values ([(v) (ptr-ref x type 'abs ofs)]
[(ptr tags types offsets T->list* list*->T)
(cstruct-info
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 TYPE? TYPE-tag make-TYPE
list->TYPE list*->TYPE TYPE->list TYPE->list*
TYPE-SLOT ... set-TYPE-SLOT! ...)))))
(define (identifiers? stx)
(andmap identifier? (syntax->list stx)))