>From 776ef16f7598822f7ae8ac2fd144f98cd8e8ea52 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 17 Aug 2014 20:33:46 +0200 Subject: [PATCH 16/19] compiler-modules: Move foreign callback code from compiler to support. Because support makes use of foreign-callback accessors, it makes more sense to put the record definition there as well. The foreign-type-table also fits better in support; after moving it there we can put accessors and setters, as well as an initialization procedure into a "proper" API which the other modules can consume. Foreign stubs are now registered through a separate API as well, so that the foreign stub list can be moved to support. Unfortunately, the c-backend still accesses this list directly. --- c-backend.scm | 113 +++++++++++------------ compiler-namespace.scm | 8 -- compiler.scm | 32 ++----- support.scm | 240 +++++++++++++++++++++++++++++------------------- 4 files changed, 205 insertions(+), 188 deletions(-) diff --git a/c-backend.scm b/c-backend.scm index 7617996..3848ede 100644 --- a/c-backend.scm +++ b/c-backend.scm @@ -1085,41 +1085,40 @@ (define (generate-foreign-callback-stubs stubs db) (for-each (lambda (stub) - (let* ([id (foreign-callback-stub-id stub)] - [rname (real-name2 id db)] - [rtype (foreign-callback-stub-return-type stub)] - [argtypes (foreign-callback-stub-argument-types stub)] - [n (length argtypes)] - [vlist (make-argument-list n "t")] ) + (let* ((id (foreign-callback-stub-id stub)) + (rname (real-name2 id db)) + (rtype (foreign-callback-stub-return-type stub)) + (argtypes (foreign-callback-stub-argument-types stub)) + (n (length argtypes)) + (vlist (make-argument-list n "t")) ) (define (compute-size type var ns) (case type - [(char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32 + ((char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32 byte unsigned-byte) - ns] - [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32 + ns) + ((float double c-pointer unsigned-integer unsigned-integer32 long integer integer32 unsigned-long size_t nonnull-c-pointer number unsigned-integer64 integer64 c-string-list c-string-list*) - (string-append ns "+3") ] - [(c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*) - (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ] - [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol) - (string-append ns "+2+C_bytestowords(C_strlen(" var "))") ] - [else - (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) - => (lambda (t) - (compute-size (if (vector? t) (vector-ref t 0) t) var ns) ) ] - [(pair? type) + (string-append ns "+3") ) + ((c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*) + (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ) + ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol) + (string-append ns "+2+C_bytestowords(C_strlen(" var "))") ) + (else + (cond ((and (symbol? type) (lookup-foreign-type type)) + => (lambda (t) (compute-size (vector-ref t 0) var ns) ) ) + ((pair? type) (case (car type) - [(ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance + ((ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance nonnull-instance instance-ref) - (string-append ns "+3") ] - [(const) (compute-size (cadr type) var ns)] - [else ns] ) ] - [else ns] ) ] ) ) + (string-append ns "+3") ) + ((const) (compute-size (cadr type) var ns)) + (else ns) ) ) + (else ns) ) ) ) ) - (let ([sizestr (fold compute-size "0" argtypes vlist)]) + (let ((sizestr (fold compute-size "0" argtypes vlist))) (gen #t) (when rname (gen #t "/* from " (cleanup rname) " */") ) @@ -1141,12 +1140,12 @@ stubs) ) (define (generate-foreign-callback-header cls stub) - (let* ([name (foreign-callback-stub-name stub)] - [quals (foreign-callback-stub-qualifiers stub)] - [rtype (foreign-callback-stub-return-type stub)] - [argtypes (foreign-callback-stub-argument-types stub)] - [n (length argtypes)] - [vlist (make-argument-list n "t")] ) + (let* ((name (foreign-callback-stub-name stub)) + (quals (foreign-callback-stub-qualifiers stub)) + (rtype (foreign-callback-stub-return-type stub)) + (argtypes (foreign-callback-stub-argument-types stub)) + (n (length argtypes)) + (vlist (make-argument-list n "t")) ) (gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\() (pair-for-each (lambda (vs ts) @@ -1195,9 +1194,9 @@ (str "unsigned char *")) ((void) (str "void")) (else - (cond ((and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) + (cond ((and (symbol? type) (lookup-foreign-type type)) => (lambda (t) - (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ) + (foreign-type-declaration (vector-ref t 0) target)) ) ((string? type) (str type)) ((list? type) (let ((len (length type))) @@ -1300,27 +1299,27 @@ nonnull-unsigned-c-string* symbol) "C_c_string(") ((bool) "C_truep(") (else - (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) + (cond ((and (symbol? type) (lookup-foreign-type type)) => (lambda (t) - (foreign-argument-conversion (if (vector? t) (vector-ref t 0) t)) ) ] - [(and (list? type) (>= (length type) 2)) + (foreign-argument-conversion (vector-ref t 0)) ) ) + ((and (list? type) (>= (length type) 2)) (case (car type) - ((c-pointer) "C_c_pointer_or_null(") - ((nonnull-c-pointer) "C_c_pointer_nn(") - ((instance) "C_c_pointer_or_null(") - ((nonnull-instance) "C_c_pointer_nn(") - ((scheme-pointer) "C_data_pointer_or_null(") - ((nonnull-scheme-pointer) "C_data_pointer(") - ((function) "C_c_pointer_or_null(") - ((const) (foreign-argument-conversion (cadr type))) - ((enum) "C_num_to_int(") - ((ref) - (string-append "*(" (foreign-type-declaration (cadr type) "*") - ")C_c_pointer_nn(")) - ((instance-ref) - (string-append "*(" (cadr type) "*)C_c_pointer_nn(")) - (else (err)) ) ] - [else (err)] ) ) ) ) ) + ((c-pointer) "C_c_pointer_or_null(") + ((nonnull-c-pointer) "C_c_pointer_nn(") + ((instance) "C_c_pointer_or_null(") + ((nonnull-instance) "C_c_pointer_nn(") + ((scheme-pointer) "C_data_pointer_or_null(") + ((nonnull-scheme-pointer) "C_data_pointer(") + ((function) "C_c_pointer_or_null(") + ((const) (foreign-argument-conversion (cadr type))) + ((enum) "C_num_to_int(") + ((ref) + (string-append "*(" (foreign-type-declaration (cadr type) "*") + ")C_c_pointer_nn(")) + ((instance-ref) + (string-append "*(" (cadr type) "*)C_c_pointer_nn(")) + (else (err)) ) ) + (else (err)) ) ) ) ) ) ;; Generate suitable conversion of a result value into Scheme data @@ -1352,10 +1351,10 @@ ((bool) "C_mk_bool(") ((void scheme-object) "((C_word)") (else - (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) + (cond ((and (symbol? type) (lookup-foreign-type type)) => (lambda (x) - (foreign-result-conversion (if (vector? x) (vector-ref x 0) x) dest)) ] - [(and (list? type) (>= (length type) 2)) + (foreign-result-conversion (vector-ref x 0) dest)) ) + ((and (list? type) (>= (length type) 2)) (case (car type) ((nonnull-pointer nonnull-c-pointer) (sprintf "C_mpointer(&~A,(void*)" dest) ) @@ -1372,8 +1371,8 @@ (sprintf "C_mpointer_or_false(&~a,(void*)" dest) ) ((function) (sprintf "C_mpointer(&~a,(void*)" dest)) ((enum) (sprintf "C_int_to_num(&~a," dest)) - (else (err)) ) ] - [else (err)] ) ) ) ) ) + (else (err)) ) ) + (else (err)) ) ) ) ) ) ;;; Encoded literals as strings, to be decoded by "C_decode_literal()" diff --git a/compiler-namespace.scm b/compiler-namespace.scm index de60046..de57b48 100644 --- a/compiler-namespace.scm +++ b/compiler-namespace.scm @@ -30,14 +30,6 @@ default-standard-bindings extended-bindings foldable-bindings - foreign-callback-stubs - foreign-callback-stub-argument-types - foreign-callback-stub-id - foreign-callback-stub-name - foreign-callback-stub-qualifiers - foreign-callback-stub-return-type - foreign-type-table - around more options. internal-bindings number-type standard-bindings diff --git a/compiler.scm b/compiler.scm index 9b6cf35..31d80de 100644 --- a/compiler.scm +++ b/compiler.scm @@ -334,7 +334,6 @@ (define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME") -(define-constant foreign-type-table-size 301) (define-constant initial-analysis-database-size 3001) (define-constant default-line-number-database-size 997) (define-constant inline-table-size 301) @@ -399,10 +398,8 @@ (define inline-substitutions-enabled #f) (define direct-call-ids '()) (define first-analysis #t) -(define foreign-type-table #f) (define foreign-variables '()) (define foreign-lambda-stubs '()) -(define foreign-callback-stubs '()) (define external-variables '()) (define external-to-pointer '()) (define location-pointer-map '()) @@ -432,9 +429,7 @@ (if file-requirements (vector-fill! file-requirements '()) (set! file-requirements (make-vector file-requirements-size '())) ) - (if foreign-type-table - (vector-fill! foreign-type-table '()) - (set! foreign-type-table (make-vector foreign-type-table-size '())) ) ) + (clear-foreign-type-table!) ) ;;; Compute general statistics from analysis database: @@ -1135,7 +1130,7 @@ (cond [(pair? conv) (let ([arg (gensym)] [ret (gensym)] ) - (##sys#hash-table-set! foreign-type-table name (vector type arg ret)) + (register-foreign-type! name type arg ret) (mark-variable arg '##compiler#always-bound) (mark-variable ret '##compiler#always-bound) (hide-variable arg) @@ -1148,7 +1143,7 @@ ,(if (pair? (cdr conv)) (second conv) '##sys#values)) ) e se dest ldest h ln) ) ] [else - (##sys#hash-table-set! foreign-type-table name type) + (register-foreign-type! name type) '(##core#undefined) ] ) ) ) ((##core#define-external-variable) @@ -1824,12 +1819,9 @@ (list (make-node 'set! (list (first params)) (list r)) (k (varnode t1)) ) ) ) ) ) ) ((##core#foreign-callback-wrapper) - (let ([id (gensym-f-id)] - [lam (first subs)] ) - (set! foreign-callback-stubs - (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) ) - ;; mark to avoid leaf-routine optimization - (mark-variable id '##compiler#callback-lambda) + (let ((id (gensym-f-id)) + (lam (first subs)) ) + (register-foreign-callback-stub! id params) (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) ) ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref ##core#inline_loc_update) @@ -1901,18 +1893,6 @@ (walk node values) ) -;;; Foreign callback stub type: - -(define-record-type foreign-callback-stub - (make-foreign-callback-stub id name qualifiers return-type argument-types) - foreign-callback-stub? - (id foreign-callback-stub-id) ; symbol - (name foreign-callback-stub-name) ; string - (qualifiers foreign-callback-stub-qualifiers) ; string - (return-type foreign-callback-stub-return-type) ; type-specifier - (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...) - - ;;; Perform source-code analysis: (define (analyze-expression node) diff --git a/support.scm b/support.scm index 4f7ab90..69b9d41 100644 --- a/support.scm +++ b/support.scm @@ -53,8 +53,14 @@ tree-copy copy-node! emit-global-inline-file load-inline-file match-node expression-has-side-effects? simple-lambda-node? dump-undefined-globals dump-defined-globals dump-global-refs + make-foreign-callback-stub foreign-callback-stub? + foreign-callback-stub-id foreign-callback-stub-name + foreign-callback-stub-qualifiers foreign-callback-stub-return-type + foreign-callback-stub-argument-types register-foreign-callback-stub! + foreign-callback-stubs ; should not be exported foreign-type-check foreign-type-convert-result foreign-type-convert-argument final-foreign-type + register-foreign-type! lookup-foreign-type clear-foreign-type-table! estimate-foreign-result-size estimate-foreign-result-location-size finish-foreign-result foreign-type->scrutiny-type scan-used-variables scan-free-variables chop-separator @@ -992,6 +998,50 @@ (debugging 'o "hiding nonexported module bindings" sym) (hide-variable sym)))) +;;; Foreign callback stub and type tables: + +(define foreign-callback-stubs '()) + +(define-record-type foreign-callback-stub + (make-foreign-callback-stub id name qualifiers return-type argument-types) + foreign-callback-stub? + (id foreign-callback-stub-id) ; symbol + (name foreign-callback-stub-name) ; string + (qualifiers foreign-callback-stub-qualifiers) ; string + (return-type foreign-callback-stub-return-type) ; type-specifier + (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...) + +(define (register-foreign-callback-stub! id params) + (set! foreign-callback-stubs + (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) ) + ;; mark to avoid leaf-routine optimization + (mark-variable id '##compiler#callback-lambda)) + +(define-constant foreign-type-table-size 301) + +(define foreign-type-table #f) + +(define (clear-foreign-type-table!) + (if foreign-type-table + (vector-fill! foreign-type-table '()) + (set! foreign-type-table (make-vector foreign-type-table-size '())) )) + +;; Register a foreign type under the given alias. type is the foreign +;; type's name, arg and ret are the *names* of conversion procedures +;; when this type is used as argument or return value, respectively. +;; The latter two must either both be supplied, or neither. +;; TODO: Maybe create a separate record type for foreign types? +(define (register-foreign-type! alias type #!optional arg ret) + (##sys#hash-table-set! foreign-type-table alias + (vector type (and ret arg) (and arg ret)))) + +;; Returns either #f (if t does not exist) or a vector with the type, +;; the *name* of the argument conversion procedure and the *name* of +;; the return value conversion procedure. If no conversion procedures +;; have been supplied, the corresponding slots will be #f. +(define (lookup-foreign-type t) + (##sys#hash-table-ref foreign-type-table t)) + ;;; Create foreign type checking expression: (define foreign-type-check ; Used only in compiler.scm @@ -1003,27 +1053,27 @@ (follow-without-loop type (lambda (t next) - (let repeat ([t t]) + (let repeat ((t t)) (case t - [(char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))] - [(int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32) - (if unsafe param `(##sys#foreign-fixnum-argument ,param))] - [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))] - [(blob scheme-pointer) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + ((char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))) + ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32) + (if unsafe param `(##sys#foreign-fixnum-argument ,param))) + ((float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))) + ((blob scheme-pointer) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp ,(if unsafe tmp `(##sys#foreign-block-argument ,tmp) ) - '#f) ) ) ] - [(nonnull-scheme-pointer nonnull-blob) + '#f) ) ) ) + ((nonnull-scheme-pointer nonnull-blob) (if unsafe param - `(##sys#foreign-block-argument ,param) ) ] + `(##sys#foreign-block-argument ,param) ) ) ((pointer-vector) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp ,(if unsafe tmp @@ -1033,96 +1083,95 @@ (if unsafe param `(##sys#foreign-struct-wrapper-argument 'pointer-vector ,param) ) ) - [(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + ((u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp ,(if unsafe tmp `(##sys#foreign-struct-wrapper-argument ',t ,tmp) ) - '#f) ) ) ] - [(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector + '#f) ) ) ) + ((nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector nonnull-f32vector nonnull-f64vector) (if unsafe param `(##sys#foreign-struct-wrapper-argument ',(##sys#slot (assq t tmap) 1) - ,param) ) ] - [(integer long size_t integer32) - (if unsafe param `(##sys#foreign-integer-argument ,param))] - [(integer64) - (if unsafe param `(##sys#foreign-integer64-argument ,param))] - [(unsigned-integer unsigned-integer32 unsigned-long) + ,param) ) ) + ((integer long size_t integer32) + (if unsafe param `(##sys#foreign-integer-argument ,param))) + ((integer64) + (if unsafe param `(##sys#foreign-integer64-argument ,param))) + ((unsigned-integer unsigned-integer32 unsigned-long) (if unsafe param - `(##sys#foreign-unsigned-integer-argument ,param) ) ] - [(unsigned-integer64) + `(##sys#foreign-unsigned-integer-argument ,param) ) ) + ((unsigned-integer64) (if unsafe param - `(##sys#foreign-unsigned-integer64-argument ,param) ) ] - [(c-pointer c-string-list c-string-list*) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + `(##sys#foreign-unsigned-integer64-argument ,param) ) ) + ((c-pointer c-string-list c-string-list*) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp (##sys#foreign-pointer-argument ,tmp) - '#f) ) ) ] - [(nonnull-c-pointer) - `(##sys#foreign-pointer-argument ,param) ] - [(c-string c-string* unsigned-c-string unsigned-c-string*) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + '#f) ) ) ) + ((nonnull-c-pointer) + `(##sys#foreign-pointer-argument ,param) ) + ((c-string c-string* unsigned-c-string unsigned-c-string*) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp ,(if unsafe `(##sys#make-c-string ,tmp) `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) ) - '#f) ) ) ] - [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) + '#f) ) ) ) + ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) (if unsafe `(##sys#make-c-string ,param) - `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ] - [(symbol) + `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ) + ((symbol) (if unsafe `(##sys#make-c-string (##sys#symbol->string ,param)) - `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ] - [else - (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t)) - => (lambda (t) - (next (if (vector? t) (vector-ref t 0) t)) ) ] - [(pair? t) + `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ) + (else + (cond ((and (symbol? t) (lookup-foreign-type t)) + => (lambda (t) (next (vector-ref t 0)) ) ) + ((pair? t) (case (car t) - [(ref pointer function c-pointer) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + ((ref pointer function c-pointer) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp (##sys#foreign-pointer-argument ,tmp) - '#f) ) ) ] - [(instance instance-ref) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + '#f) ) ) ) + ((instance instance-ref) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp (slot-ref ,param 'this) - '#f) ) ) ] - [(scheme-pointer) - (let ([tmp (gensym)]) - `(let ([,tmp ,param]) + '#f) ) ) ) + ((scheme-pointer) + (let ((tmp (gensym))) + `(let ((,tmp ,param)) (if ,tmp ,(if unsafe tmp `(##sys#foreign-block-argument ,tmp) ) - '#f) ) ) ] - [(nonnull-scheme-pointer) + '#f) ) ) ) + ((nonnull-scheme-pointer) (if unsafe param - `(##sys#foreign-block-argument ,param) ) ] - [(nonnull-instance) - `(slot-ref ,param 'this) ] - [(const) (repeat (cadr t))] - [(enum) - (if unsafe param `(##sys#foreign-integer-argument ,param))] - [(nonnull-pointer nonnull-c-pointer) - `(##sys#foreign-pointer-argument ,param) ] - [else param] ) ] - [else param] ) ] ) ) ) + `(##sys#foreign-block-argument ,param) ) ) + ((nonnull-instance) + `(slot-ref ,param 'this) ) + ((const) (repeat (cadr t))) + ((enum) + (if unsafe param `(##sys#foreign-integer-argument ,param))) + ((nonnull-pointer nonnull-c-pointer) + `(##sys#foreign-pointer-argument ,param) ) + (else param) ) ) + (else param) ) ) ) ) ) (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) ) ) ) @@ -1130,27 +1179,26 @@ ;;; Compute foreign-type conversions: (define (foreign-type-convert-result r t) ; Used only in compiler.scm - (or (and-let* ([(symbol? t)] - [ft (##sys#hash-table-ref foreign-type-table t)] - [(vector? ft)] ) - (list (vector-ref ft 2) r) ) + (or (and-let* (((symbol? t)) + (ft (lookup-foreign-type t)) + (retconv (vector-ref ft 2)) ) + (list retconv r) ) r) ) (define (foreign-type-convert-argument a t) ; Used only in compiler.scm - (or (and-let* ([(symbol? t)] - [ft (##sys#hash-table-ref foreign-type-table t)] - [(vector? ft)] ) - (list (vector-ref ft 1) a) ) + (or (and-let* (((symbol? t)) + (ft (lookup-foreign-type t)) + (argconv (vector-ref ft 1)) ) + (list argconv a) ) a) ) (define (final-foreign-type t0) ; Used only in compiler.scm (follow-without-loop t0 (lambda (t next) - (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t)) - => (lambda (t2) - (next (if (vector? t2) (vector-ref t2 0) t2)) ) ] - [else t] ) ) + (cond ((and (symbol? t) (lookup-foreign-type t)) + => (lambda (t2) (next (vector-ref t2 0)) ) ) + (else t) ) ) (lambda () (quit-compiling "foreign type `~S' refers to itself" t0)) ) ) @@ -1173,15 +1221,14 @@ ((float double number integer64 unsigned-integer64) (words->bytes 4) ) ; possibly 8-byte aligned 64-bit double (else - (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t)) - => (lambda (t2) - (next (if (vector? t2) (vector-ref t2 0) t2)) ) ] - [(pair? t) + (cond ((and (symbol? t) (lookup-foreign-type t)) + => (lambda (t2) (next (vector-ref t2 0)) ) ) + ((pair? t) (case (car t) - [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance) - (words->bytes 3) ] - [else 0] ) ] - [else 0] ) ) ) ) + ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance) + (words->bytes 3) ) + (else 0) ) ) + (else 0) ) ) ) ) (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) ) (define (estimate-foreign-result-location-size type) ; Used only in compiler.scm @@ -1200,16 +1247,15 @@ ((double number integer64 unsigned-integer64) (words->bytes 2) ) (else - (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t)) - => (lambda (t2) - (next (if (vector? t2) (vector-ref t2 0) t2)) ) ] - [(pair? t) + (cond ((and (symbol? t) (lookup-foreign-type t)) + => (lambda (t2) (next (vector-ref t2 0)) ) ) + ((pair? t) (case (car t) - [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function + ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function scheme-pointer nonnull-scheme-pointer) - (words->bytes 1)] - [else (err t)] ) ] - [else (err t)] ) ) ) ) + (words->bytes 1)) + (else (err t)) ) ) + (else (err t)) ) ) ) ) (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) ) -- 1.7.10.4