From a1a0262c659840a80ea975392eef84fd2408ea6b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 9 Apr 2005 20:58:28 +0000 Subject: [PATCH] made it possible for a cstruct to have pointers to itself original commit: edb73f0a7d29e4e0f1c0ba12bbb876e87dd2f335 --- collects/mzlib/foreign.ss | 181 ++++++++++++++++++++------------------ 1 file changed, 97 insertions(+), 84 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 6eb84ba..dcb7dcb 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1249,10 +1249,12 @@ (datum->syntax-object _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx)) (define (ids name-func) - (map (lambda (s stx) + (map (lambda (s) (datum->syntax-object - stx (string->symbol (apply string-append (name-func s))) stx)) - slot-names (syntax->list slot-names-stx))) + _TYPE-stx + (string->symbol (apply string-append (name-func s))) + _TYPE-stx)) + slot-names)) (with-syntax ([first-type (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs)))] @@ -1263,6 +1265,8 @@ [(slot-type ...) slot-types-stx] [_TYPE _TYPE-stx] [_TYPE-pointer (id "_"name"-pointer")] + [_TYPE-pointer/null (id "_"name"-pointer/null")] + [_TYPE/null (id "_"name"/null")] [_TYPE* (id "_"name"*")] [TYPE? (id name"?")] [make-TYPE (id "make-"name)] @@ -1276,93 +1280,102 @@ [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] [(offset ...) (generate-temporaries (ids (lambda (s) `(,s"-offset"))))]) - #'(define-values (_TYPE _TYPE-pointer TYPE? TYPE-tag make-TYPE - list->TYPE list*->TYPE TYPE->list TYPE->list* + #'(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! ...) - (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 - super->list* list*->super) - (cstruct-info first-type - (lambda () (values #f '() #f #f #f #f)))) + (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) - (define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types))) - (define all-tags (cons TYPE-tag super-tags)) - (define-values (all-types all-offsets) - (if (and has-super? super-types super-offsets) - (values (append super-types (cdr types)) - (append super-offsets (cdr offsets))) - (values types offsets))) - (define (TYPE-SLOT x) - (unless (TYPE? x) (raise-type-error 'TYPE-SLOT struct-string x)) - (ptr-ref x stype 'abs offset)) - ... - (define (set-TYPE-SLOT! x slot) - (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)) + ;; 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 ...)] + [(types) (list stype ...)] + [(offsets) (compute-offsets types)] + [(offset ...) (apply values offsets)]) + (define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types))) + (define all-tags (cons TYPE-tag super-tags)) + (define-values (all-types all-offsets) + (if (and has-super? super-types super-offsets) + (values (append super-types (cdr types)) + (append super-offsets (cdr offsets))) + (values types offsets))) + (define (TYPE-SLOT x) + (unless (TYPE? x) + (raise-type-error 'TYPE-SLOT struct-string x)) + (ptr-ref x stype 'abs offset)) + ... + (define (set-TYPE-SLOT! x slot) + (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*)]) (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 ...) + (ptr-set! block stype 'abs offset slot) + ... + block)))) + (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) - (ptr-set! block stype 'abs offset slot) - ... - block)))) - (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)) - (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! ...))))) + (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)) + (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-pointer _TYPE-pointer/null 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))) (define (_-identifier? stx)