Chez Scheme: generalize __varargs to (__varargs_after <n>)
The non-standard ARM Mac OS ABI doesn't just use a different convention if the function has varargs: it puts each vararg in a different place than a non-vararg argument of the same type and position. So, `foreign-procedure` and `foreign-callable` need to know where varargs start. A `__varargs` declaration is shorthand for `(__varargs_after 1)`. For PPC32 Mac OS, we retain the trick that makes varargs foreign calls work without a `__varargs` declaration, but `(__varargs_after <n>)` fixes up callable support --- in the extremely unlikely case that someone needs general varargs callables on PPC32 Mac OS.
This commit is contained in:
Matthew Flatt
parent
0ce89f53c4
commit
6033237ed6
|
|
@ -221,9 +221,11 @@ Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is
|
|||
equivalent to specifying \scheme{#f} or no convention.
|
||||
Finally, \var{conv} can be \scheme{__collect_safe} to indicate that garbage
|
||||
collection is allowed concurrent to a call of the foreign procedure, or it
|
||||
can be \var{conv} can be \scheme{__varargs} to indicate that the procedure
|
||||
uses a convention that works with a variable number of arguments (which
|
||||
differs from the fixed-argument variant for some platforms and conventions).
|
||||
can be \var{conv} can be \scheme{__varargs} or \scheme{(__varargs_after \var{n})} to indicate
|
||||
that the procedure uses a convention that works with a variable number of arguments
|
||||
after the first \var{n} (which
|
||||
differs from the fixed-argument variant for some platforms and conventions),
|
||||
where \scheme{__varargs} is a shorthand for \scheme{(__varargs_after 1)}.
|
||||
|
||||
Use \scheme{__stdcall} to access most Windows API procedures.
|
||||
Use \scheme{__cdecl} for Windows API varargs procedures,
|
||||
|
|
|
|||
|
|
@ -1044,10 +1044,13 @@
|
|||
(define call-df (foreign-procedure "call_df" (ptr double-float int int) double-float))
|
||||
(define call-varargs-df (foreign-procedure "call_varargs_df" (ptr double-float int int) double-float))
|
||||
(define call-varargs-i7df (foreign-procedure "call_varargs_i7df" (ptr int
|
||||
double-float double-float double-float
|
||||
double-float double-float double-float
|
||||
double-float)
|
||||
double-float double-float double-float
|
||||
double-float double-float double-float
|
||||
double-float)
|
||||
double-float))
|
||||
(define call-varargs-dfii (foreign-procedure "call_varargs_dfii" (ptr double-float int int) double-float))
|
||||
(define call-varargs-dfidf (foreign-procedure "call_varargs_dfidf" (ptr double-float int double-float) double-float))
|
||||
(define call-varargs-dfsfi (foreign-procedure "call_varargs_dfsfi" (ptr double-float single-float int) double-float))
|
||||
(define ($test-call-int signed? size call-int make-fc)
|
||||
(define n10000 (expt 256 size))
|
||||
(define nffff (- n10000 1))
|
||||
|
|
@ -1178,6 +1181,35 @@
|
|||
1 2.2 3.2 4.5 6.7 8.9 10.1 11.5)
|
||||
55.1)
|
||||
|
||||
(equal?
|
||||
(call-varargs-dfii
|
||||
(foreign-callable
|
||||
(__varargs_after 2)
|
||||
(lambda (x y z) (+ x y z))
|
||||
(double-float int int) double-float)
|
||||
10.25 20 300)
|
||||
620.25)
|
||||
|
||||
(equal?
|
||||
(call-varargs-dfidf
|
||||
(foreign-callable
|
||||
(__varargs_after 2)
|
||||
(lambda (x y z) (+ x y z))
|
||||
(double-float int double-float) double-float)
|
||||
10.25 20 300.25)
|
||||
330.75)
|
||||
|
||||
(equal?
|
||||
(call-varargs-dfsfi
|
||||
(foreign-callable
|
||||
(__varargs_after 2)
|
||||
(lambda (x y z) (+ x y z))
|
||||
(double-float single-float int) double-float)
|
||||
10.25 20.0 300)
|
||||
620.5)
|
||||
|
||||
;(define call-varargs-dfsfi (foreign-procedure #;__varargs #;2 "call_varargs_dfsfi" (ptr double-float single-float int) double-float))
|
||||
|
||||
(error?
|
||||
(call-i8
|
||||
(foreign-callable
|
||||
|
|
@ -2738,6 +2770,12 @@
|
|||
[(i3osx ti3osx a6osx ta6osx ppc32osx tppc32osx arm64osx tarm64osx)
|
||||
'(load-shared-object "libc.dylib")]
|
||||
[else (error 'load-libc "unrecognized machine type ~s" (machine-type))]))
|
||||
(define varargs_df (foreign-procedure (__varargs_after 1) "varargs_df" (double int int) double))
|
||||
(define varargs_dfii (foreign-procedure (__varargs_after 2) "varargs_dfii" (double int int) double))
|
||||
(define varargs_dfidf (foreign-procedure (__varargs_after 2) "varargs_dfidf" (double int double) double))
|
||||
(define varargs_sfdfi (foreign-procedure (__varargs_after 2) "varargs_sfdfi" (float double int) double))
|
||||
(define varargs_i7df (foreign-procedure (__varargs_after 1) "varargs_i7df" (int double double double double double double double)
|
||||
double))
|
||||
#t)
|
||||
(equal?
|
||||
(with-input-from-string
|
||||
|
|
@ -2798,6 +2836,22 @@
|
|||
(double-float double-float) single-float)
|
||||
3.5 -5.25)))
|
||||
3.25)
|
||||
|
||||
(equal?
|
||||
(varargs_df 13.5 7 10)
|
||||
30.5)
|
||||
(equal?
|
||||
(varargs_dfii 13.5 -7 -10)
|
||||
-3.5)
|
||||
(equal?
|
||||
(varargs_dfidf 13.5 10 7.5)
|
||||
31.0)
|
||||
(equal?
|
||||
(varargs_sfdfi 10.5 3.25 8)
|
||||
21.75)
|
||||
(equal?
|
||||
(varargs_i7df 1 2.0 3.0 4.0 5.0 6.0 7.0 8.0)
|
||||
36.0)
|
||||
)
|
||||
|
||||
(mat structs
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
|
||||
#include <stdio.h>
|
||||
#include <wchar.h>
|
||||
#include <stdarg.h>
|
||||
|
||||
#ifdef _WIN32
|
||||
# define SCHEME_IMPORT
|
||||
|
|
@ -244,10 +245,27 @@ EXPORT double_float call_df(ptr code, double_float x, int m, int k) {
|
|||
return (*((double_float (*) (double_float))Sforeign_callable_entry_point(code)))(x + m) + k;
|
||||
}
|
||||
|
||||
/* varargs after 1 argument */
|
||||
EXPORT double_float call_varargs_df(ptr code, double_float x, int m, int k) {
|
||||
return (*((double_float (*) (double, ...))Sforeign_callable_entry_point(code)))(x - m, x + m) + k;
|
||||
}
|
||||
|
||||
/* varargs after 2 arguments */
|
||||
EXPORT double_float call_varargs_dfii(ptr code, double_float x, int m, int k) {
|
||||
return (*((double_float (*) (double, int, ...))Sforeign_callable_entry_point(code)))(x - m, x + m, k) + k;
|
||||
}
|
||||
|
||||
/* varargs after 2 arguments */
|
||||
EXPORT double_float call_varargs_dfidf(ptr code, double_float x, int m, double k) {
|
||||
return (*((double_float (*) (double, int, ...))Sforeign_callable_entry_point(code)))(x - m, x + m, x) + k;
|
||||
}
|
||||
|
||||
/* varargs after 2 arguments */
|
||||
EXPORT double_float call_varargs_dfsfi(ptr code, double_float x, single_float m, int k) {
|
||||
return (*((double_float (*) (double, float, ...))Sforeign_callable_entry_point(code)))(x - m, x + m, k) + k;
|
||||
}
|
||||
|
||||
/* varargs after 1 argument */
|
||||
EXPORT double_float call_varargs_i7df(ptr code, int i,
|
||||
double_float a, double_float b, double_float c,
|
||||
double_float d, double_float e, double_float f,
|
||||
|
|
@ -255,6 +273,62 @@ EXPORT double_float call_varargs_i7df(ptr code, int i,
|
|||
return (*((double_float (*) (int, ...))Sforeign_callable_entry_point(code)))(i, a, b, c, d, e, f, g);
|
||||
}
|
||||
|
||||
EXPORT double_float varargs_df(double_float x, ...) {
|
||||
va_list va;
|
||||
int m, k;
|
||||
va_start(va, x);
|
||||
m = va_arg(va, int);
|
||||
k = va_arg(va, int);
|
||||
va_end(va);
|
||||
return x + m + k;
|
||||
}
|
||||
|
||||
EXPORT double_float varargs_dfii(double_float x, int m, ...) {
|
||||
va_list va;
|
||||
int k;
|
||||
va_start(va, m);
|
||||
k = va_arg(va, int);
|
||||
va_end(va);
|
||||
return x + m + k;
|
||||
}
|
||||
|
||||
EXPORT double_float varargs_dfidf(double_float x, int m, ...) {
|
||||
va_list va;
|
||||
double k;
|
||||
va_start(va, m);
|
||||
k = va_arg(va, double);
|
||||
va_end(va);
|
||||
return x + m + k;
|
||||
}
|
||||
|
||||
EXPORT double_float varargs_sfdfi(single_float x, double_float m, ...) {
|
||||
va_list va;
|
||||
int k;
|
||||
va_start(va, m);
|
||||
k = va_arg(va, int);
|
||||
va_end(va);
|
||||
return x + m + k;
|
||||
}
|
||||
|
||||
EXPORT double_float varargs_i7df(int i, ...) {
|
||||
va_list va;
|
||||
double_float a, b, c;
|
||||
double_float d, e, f;
|
||||
double_float g;
|
||||
|
||||
va_start(va, i);
|
||||
a = va_arg(va, double_float);
|
||||
b = va_arg(va, double_float);
|
||||
c = va_arg(va, double_float);
|
||||
d = va_arg(va, double_float);
|
||||
e = va_arg(va, double_float);
|
||||
f = va_arg(va, double_float);
|
||||
g = va_arg(va, double_float);
|
||||
va_end(va);
|
||||
|
||||
return a + b + c + d + e + f + g + i;
|
||||
}
|
||||
|
||||
EXPORT u8 *u8_star_to_u8_star(u8 *s) {
|
||||
return s == (u8 *)0 ? (u8 *)0 : s + 1;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -2770,7 +2770,7 @@
|
|||
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
|
||||
(let* ([arg-type* (info-foreign-arg-type* info)]
|
||||
[conv* (info-foreign-conv* info)]
|
||||
[varargs? (memq 'varargs conv*)]
|
||||
[varargs? (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs))) conv*)]
|
||||
[result-type (info-foreign-result-type info)]
|
||||
[result-reg* (get-result-regs result-type varargs?)]
|
||||
[fill-result-here? (indirect-result-that-fits-in-registers? result-type)]
|
||||
|
|
@ -3240,7 +3240,7 @@
|
|||
(vector->list regvec)))
|
||||
(let* ([arg-type* (info-foreign-arg-type* info)]
|
||||
[conv* (info-foreign-conv* info)]
|
||||
[varargs? (memq 'varargs conv*)]
|
||||
[varargs? (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs))) conv*)]
|
||||
[result-type (info-foreign-result-type info)]
|
||||
[synthesize-first? (indirect-result-that-fits-in-registers? result-type)]
|
||||
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
|
||||
|
|
|
|||
|
|
@ -2421,6 +2421,11 @@
|
|||
(inline ,(make-info-kill*-live* fp-regs '()) ,%pop-fpmultiple))])))])
|
||||
(save-and-restore-gp regs (save-and-restore-fp regs e))))))
|
||||
|
||||
(define (extract-varargs-after-conv conv*)
|
||||
(ormap (lambda (conv)
|
||||
(and (pair? conv) (eq? (car conv) 'varargs) (cdr conv)))
|
||||
conv*))
|
||||
|
||||
(define-record-type cat
|
||||
(nongenerative #{cat jqrttgvpydsbdo0l736l43udu-1})
|
||||
(sealed #t)
|
||||
|
|
@ -2431,11 +2436,11 @@
|
|||
indirect-bytes)) ; #f or extra bytes on stack for indirect
|
||||
|
||||
(define alignment-via-lookahead
|
||||
(lambda (size types stack-align varargs? k)
|
||||
(lambda (size types stack-align varargs-after k)
|
||||
(constant-case machine-type-name
|
||||
[(arm64osx tarm64osx)
|
||||
(cond
|
||||
[varargs? (k (align 8 size) 0 0)]
|
||||
[(eqv? 0 varargs-after) (k (align 8 size) 0 0)]
|
||||
[else
|
||||
;; On Mac OS, a non-varargs stack argument does not have to use a
|
||||
;; multiple of 8, but we need to work out any padding that
|
||||
|
|
@ -2463,14 +2468,12 @@
|
|||
(k (align 8 size) 0 0)])))
|
||||
|
||||
(define rest-of
|
||||
(lambda (regs n varargs?)
|
||||
(lambda (regs n next-varargs-after)
|
||||
(constant-case machine-type-name
|
||||
[(arm64osx tarm64osx)
|
||||
(cond
|
||||
[varargs?
|
||||
;; Assume (arbitraily) that all but the first argument
|
||||
;; is varargs, which means that all the rest go on the
|
||||
;; stack.
|
||||
[(eqv? next-varargs-after 0)
|
||||
;; All the rest go on the stack
|
||||
'()]
|
||||
[else
|
||||
(list-tail regs n)])]
|
||||
|
|
@ -2478,108 +2481,123 @@
|
|||
(list-tail regs n)])))
|
||||
|
||||
(define categorize-arguments
|
||||
(lambda (types varargs?)
|
||||
(lambda (types varargs-after)
|
||||
(let loop ([types types] [int* (int-argument-regs)] [fp* (fp-argument-regs)]
|
||||
[varargs-after varargs-after]
|
||||
;; accumulate alignment from previous args so we can compute any
|
||||
;; needed padding and alignment after this next argument
|
||||
[stack-align 0])
|
||||
(if (null? types)
|
||||
'()
|
||||
(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-double-float)
|
||||
(cond
|
||||
[(null? fp*)
|
||||
(cons (make-cat 'stack '() 8 0 #f) (loop (cdr types) int* '() 0))]
|
||||
[else
|
||||
(cons (make-cat 'fp (list (car fp*)) 8 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 varargs?) (rest-of fp* 1 varargs?) stack-align))])]
|
||||
[(fp-single-float)
|
||||
(cond
|
||||
[(null? fp*)
|
||||
(alignment-via-lookahead
|
||||
4 (cdr types) stack-align varargs?
|
||||
(lambda (bytes pad stack-align)
|
||||
(cons (make-cat 'stack '() bytes pad #f) (loop (cdr types) int* '() stack-align))))]
|
||||
[else
|
||||
(cons (make-cat 'fp (list (car fp*)) 8 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 varargs?)(rest-of fp* 1 varargs?) stack-align))])]
|
||||
[(fp-ftd& ,ftd)
|
||||
(let* ([size ($ftd-size ftd)]
|
||||
[members ($ftd->members ftd)]
|
||||
[num-members (length members)]
|
||||
[doubles? (and (fx= 8 ($ftd-alignment ftd))
|
||||
(fx<= num-members 4)
|
||||
(andmap double-member? members))]
|
||||
[floats? (and (fx= 4 ($ftd-alignment ftd))
|
||||
(fx<= num-members 4)
|
||||
(andmap float-member? members))])
|
||||
(let ([next-varargs-after (and varargs-after (if (fx> varargs-after 0) (fx- varargs-after 1) 0))])
|
||||
(if (null? types)
|
||||
'()
|
||||
(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-double-float)
|
||||
(cond
|
||||
[doubles?
|
||||
;; Sequence of up to 4 doubles that may fit in registers
|
||||
(cond
|
||||
[(fx>= (length fp*) num-members)
|
||||
;; Allocate each double to a register
|
||||
(cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 varargs?) (rest-of fp* num-members varargs?) stack-align))]
|
||||
[else
|
||||
;; Stop using fp registers, put on stack
|
||||
(cons (make-cat 'stack '() size 0 #f)
|
||||
(loop (cdr types) int* '() 0))])]
|
||||
[floats?
|
||||
;; Sequence of up to 4 floats that may fit in registers
|
||||
(cond
|
||||
[(fx>= (length fp*) num-members)
|
||||
;; Allocate each float to a register
|
||||
(cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 varargs?) (rest-of fp* num-members varargs?) stack-align))]
|
||||
[else
|
||||
;; Stop using fp registers, put on stack
|
||||
(alignment-via-lookahead
|
||||
size (cdr types) stack-align varargs?
|
||||
(lambda (size pad stack-align)
|
||||
(cons (make-cat 'stack '() size pad #f)
|
||||
(loop (cdr types) int* '() stack-align))))])]
|
||||
[(fx> size 16)
|
||||
;; Indirect; pointer goes in a register or on the stack
|
||||
(cond
|
||||
[(null? int*)
|
||||
;; Pointer on the stack
|
||||
(cons (make-cat 'stack '() (constant ptr-bytes) 0 (align 8 size))
|
||||
(loop (cdr types) '() fp* 0))]
|
||||
[else
|
||||
;; Pointer in register
|
||||
(cons (make-cat 'int (list (car int*)) 8 0 (align 8 size))
|
||||
(loop (cdr types) (rest-of int* 1 varargs?) (rest-of fp* 0 varargs?) stack-align))])]
|
||||
[(null? fp*)
|
||||
(cons (make-cat 'stack '() 8 0 #f) (loop (cdr types) int* '() next-varargs-after 0))]
|
||||
[else
|
||||
;; Maybe put in integer registers
|
||||
(let* ([regs (fxquotient (align 8 size) 8)])
|
||||
(cons (make-cat 'fp (list (car fp*)) 8 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* 1 next-varargs-after)
|
||||
next-varargs-after
|
||||
stack-align))])]
|
||||
[(fp-single-float)
|
||||
(cond
|
||||
[(null? fp*)
|
||||
(alignment-via-lookahead
|
||||
4 (cdr types) stack-align varargs-after
|
||||
(lambda (bytes pad stack-align)
|
||||
(cons (make-cat 'stack '() bytes pad #f) (loop (cdr types) int* '() next-varargs-after stack-align))))]
|
||||
[else
|
||||
(cons (make-cat 'fp (list (car fp*)) 8 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 next-varargs-after)(rest-of fp* 1 next-varargs-after)
|
||||
next-varargs-after
|
||||
stack-align))])]
|
||||
[(fp-ftd& ,ftd)
|
||||
(let* ([size ($ftd-size ftd)]
|
||||
[members ($ftd->members ftd)]
|
||||
[num-members (length members)]
|
||||
[doubles? (and (fx= 8 ($ftd-alignment ftd))
|
||||
(fx<= num-members 4)
|
||||
(andmap double-member? members))]
|
||||
[floats? (and (fx= 4 ($ftd-alignment ftd))
|
||||
(fx<= num-members 4)
|
||||
(andmap float-member? members))])
|
||||
(cond
|
||||
[doubles?
|
||||
;; Sequence of up to 4 doubles that may fit in registers
|
||||
(cond
|
||||
[(fx<= regs (length int*))
|
||||
;; Fits in registers
|
||||
(cons (make-cat 'int (list-head int* regs) (align 8 size) 0 #f)
|
||||
(loop (cdr types) (rest-of int* regs varargs?) (rest-of fp* 0 varargs?) stack-align))]
|
||||
[(fx>= (length fp*) num-members)
|
||||
;; Allocate each double to a register
|
||||
(cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* num-members next-varargs-after)
|
||||
next-varargs-after
|
||||
stack-align))]
|
||||
[else
|
||||
;; Stop using int registers, put on stack
|
||||
;; Stop using fp registers, put on stack
|
||||
(cons (make-cat 'stack '() size 0 #f)
|
||||
(loop (cdr types) int* '() next-varargs-after 0))])]
|
||||
[floats?
|
||||
;; Sequence of up to 4 floats that may fit in registers
|
||||
(cond
|
||||
[(fx>= (length fp*) num-members)
|
||||
;; Allocate each float to a register
|
||||
(cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f)
|
||||
(loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* num-members next-varargs-after)
|
||||
next-varargs-after
|
||||
stack-align))]
|
||||
[else
|
||||
;; Stop using fp registers, put on stack
|
||||
(alignment-via-lookahead
|
||||
size (cdr types) stack-align varargs?
|
||||
size (cdr types) stack-align varargs-after
|
||||
(lambda (size pad stack-align)
|
||||
(cons (make-cat 'stack '() size pad #f)
|
||||
(loop (cdr types) '() fp* stack-align))))]))]))]
|
||||
[else
|
||||
;; integers, scheme-object, etc.
|
||||
(cond
|
||||
[(null? int*)
|
||||
(let ([size (nanopass-case (Ltype Type) (car types)
|
||||
[(fp-integer ,bits) (fxquotient bits 8)]
|
||||
[(fp-unsigned ,bits) (fxquotient bits 8)]
|
||||
[else 8])])
|
||||
(alignment-via-lookahead
|
||||
size (cdr types) stack-align varargs?
|
||||
(lambda (size pad stack-align)
|
||||
(cons (make-cat 'stack '() size pad #f) (loop (cdr types) '() fp* stack-align)))))]
|
||||
[else
|
||||
(cons (make-cat 'int (list (car int*)) 8 0 #f)
|
||||
(loop (cdr types) (rest-of int* 1 varargs?) (rest-of fp* 0 varargs?) stack-align))])])))))
|
||||
(loop (cdr types) int* '() next-varargs-after stack-align))))])]
|
||||
[(fx> size 16)
|
||||
;; Indirect; pointer goes in a register or on the stack
|
||||
(cond
|
||||
[(null? int*)
|
||||
;; Pointer on the stack
|
||||
(cons (make-cat 'stack '() (constant ptr-bytes) 0 (align 8 size))
|
||||
(loop (cdr types) '() fp* next-varargs-after 0))]
|
||||
[else
|
||||
;; Pointer in register
|
||||
(cons (make-cat 'int (list (car int*)) 8 0 (align 8 size))
|
||||
(loop (cdr types) (rest-of int* 1 next-varargs-after) (rest-of fp* 0 next-varargs-after)
|
||||
next-varargs-after
|
||||
stack-align))])]
|
||||
[else
|
||||
;; Maybe put in integer registers
|
||||
(let* ([regs (fxquotient (align 8 size) 8)])
|
||||
(cond
|
||||
[(fx<= regs (length int*))
|
||||
;; Fits in registers
|
||||
(cons (make-cat 'int (list-head int* regs) (align 8 size) 0 #f)
|
||||
(loop (cdr types) (rest-of int* regs next-varargs-after) (rest-of fp* 0 next-varargs-after)
|
||||
next-varargs-after
|
||||
stack-align))]
|
||||
[else
|
||||
;; Stop using int registers, put on stack
|
||||
(alignment-via-lookahead
|
||||
size (cdr types) stack-align varargs-after
|
||||
(lambda (size pad stack-align)
|
||||
(cons (make-cat 'stack '() size pad #f)
|
||||
(loop (cdr types) '() fp* next-varargs-after stack-align))))]))]))]
|
||||
[else
|
||||
;; integers, scheme-object, etc.
|
||||
(cond
|
||||
[(null? int*)
|
||||
(let ([size (nanopass-case (Ltype Type) (car types)
|
||||
[(fp-integer ,bits) (fxquotient bits 8)]
|
||||
[(fp-unsigned ,bits) (fxquotient bits 8)]
|
||||
[else 8])])
|
||||
(alignment-via-lookahead
|
||||
size (cdr types) stack-align varargs-after
|
||||
(lambda (size pad stack-align)
|
||||
(cons (make-cat 'stack '() size pad #f) (loop (cdr types) '() fp* next-varargs-after stack-align)))))]
|
||||
[else
|
||||
(cons (make-cat 'int (list (car int*)) 8 0 #f)
|
||||
(loop (cdr types) (rest-of int* 1 next-varargs-after) (rest-of fp* 0 next-varargs-after)
|
||||
next-varargs-after stack-align))])]))))))
|
||||
|
||||
(define get-registers
|
||||
(lambda (cats kind)
|
||||
|
|
@ -2892,7 +2910,7 @@
|
|||
(cdr arg-type*)
|
||||
arg-type*)]
|
||||
[conv* (info-foreign-conv* info)]
|
||||
[arg-cat* (categorize-arguments arg-type* (memq 'varargs conv*))]
|
||||
[arg-cat* (categorize-arguments arg-type* (extract-varargs-after-conv conv*))]
|
||||
[result-cat (car (categorize-arguments (list result-type) #f))]
|
||||
[result-reg* (cat-regs result-cat)]
|
||||
[fill-result-here? (and ftd-result?
|
||||
|
|
@ -3225,7 +3243,7 @@
|
|||
(cdr arg-type*)
|
||||
arg-type*)]
|
||||
[conv* (info-foreign-conv* info)]
|
||||
[arg-cat* (categorize-arguments arg-type* (memq 'varargs conv*))]
|
||||
[arg-cat* (categorize-arguments arg-type* (extract-varargs-after-conv conv*))]
|
||||
[result-cat (car (categorize-arguments (list result-type) #f))]
|
||||
[synthesize-first? (and ftd-result?
|
||||
(not (cat-indirect-bytes result-cat))
|
||||
|
|
|
|||
|
|
@ -157,7 +157,9 @@
|
|||
|
||||
(define convention?
|
||||
(lambda (x)
|
||||
(symbol? x)))
|
||||
(or (symbol? x)
|
||||
(and (pair? x)
|
||||
(eq? 'varargs (car x))))))
|
||||
|
||||
(define-record-type preinfo
|
||||
(nongenerative #{preinfo e23pkvo5btgapnzomqgegm-2})
|
||||
|
|
|
|||
|
|
@ -556,7 +556,7 @@ ftype operators:
|
|||
(make-ftd-function rtd/fptr
|
||||
(and defid (symbol->string (syntax->datum defid)))
|
||||
stype #f #f
|
||||
($filter-conv 'function-ftype #'(conv ...))
|
||||
($filter-conv 'function-ftype #'(conv ...) (length #'(arg-type ...)))
|
||||
(map (lambda (x) (filter-type r x #f)) #'(arg-type ...))
|
||||
(filter-type r #'result-type #t)))]
|
||||
[(packed-kwd ftype)
|
||||
|
|
|
|||
|
|
@ -3057,13 +3057,9 @@
|
|||
;; we push all of the int reg args with one push instruction and all of the
|
||||
;; float reg args with another (v)push instruction. It's possible for an argument
|
||||
;; to be split across a register and the stack --- but in that case, there's
|
||||
;; room just before on the stack to copy in the register. For varrags, the
|
||||
;; `__varargs` isn't technically enough information, because the ABI is specified
|
||||
;; in terms of specific unknown arguments (i.e., the part in the "..."); we
|
||||
;; just assume that all argument except the first are in "...", and that assumption
|
||||
;; only matters for `double` arguments.
|
||||
;; room just before on the stack to copy in the register.
|
||||
(lambda (types gp-reg-count fp-reg-count init-int-reg-offset float-reg-offset stack-arg-offset
|
||||
synthesize-first-argument? varargs? return-space-offset)
|
||||
synthesize-first-argument? varargs-after return-space-offset)
|
||||
(let loop ([types (if synthesize-first-argument? (cdr types) types)]
|
||||
[locs '()]
|
||||
[iint 0]
|
||||
|
|
@ -3071,133 +3067,144 @@
|
|||
[int-reg-offset init-int-reg-offset]
|
||||
[float-reg-offset float-reg-offset]
|
||||
[stack-arg-offset (fx- stack-arg-offset (fx- stack-arguments-starting-offset
|
||||
register+stack-arguments-starting-offset))])
|
||||
(if (null? types)
|
||||
(let ([locs (reverse locs)])
|
||||
(if synthesize-first-argument?
|
||||
(cons (load-stack-address return-space-offset)
|
||||
locs)
|
||||
locs))
|
||||
(cond
|
||||
[(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-double-float) 2]
|
||||
[(fp-single-float) 1]
|
||||
[else #f])
|
||||
=> (lambda (width)
|
||||
(let ([size (fx* width 4)])
|
||||
(cond
|
||||
[(and (fx< iflt fp-reg-count)
|
||||
(or (not varargs?)
|
||||
;; hack: varargs function requires at least one argument
|
||||
(fx= int-reg-offset init-int-reg-offset)))
|
||||
;; in FP register
|
||||
register+stack-arguments-starting-offset))]
|
||||
[varargs-after varargs-after])
|
||||
(let ([next-varargs-after (and varargs-after (if (fx> varargs-after 0) (fx- varargs-after 1) 0))])
|
||||
(if (null? types)
|
||||
(let ([locs (reverse locs)])
|
||||
(if synthesize-first-argument?
|
||||
(cons (load-stack-address return-space-offset)
|
||||
locs)
|
||||
locs))
|
||||
(cond
|
||||
[(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-double-float) 2]
|
||||
[(fp-single-float) 1]
|
||||
[else #f])
|
||||
=> (lambda (width)
|
||||
(let ([size (fx* width 4)])
|
||||
(cond
|
||||
[(and (fx< iflt fp-reg-count)
|
||||
(not (eq? varargs-after 0)))
|
||||
;; in FP register
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack float-reg-offset) locs)
|
||||
(fx+ iint width) (fx+ iflt 1) (fx+ int-reg-offset size) (fx+ float-reg-offset size)
|
||||
(fx+ stack-arg-offset size)
|
||||
next-varargs-after)]
|
||||
[(or (not (eq? varargs-after 0))
|
||||
(fx>= iint gp-reg-count))
|
||||
;; on stack
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack stack-arg-offset) locs)
|
||||
iint iflt int-reg-offset float-reg-offset
|
||||
(fx+ stack-arg-offset size)
|
||||
next-varargs-after)]
|
||||
[else ;; => varargs
|
||||
;; in integer register --- but maybe halfway on stack
|
||||
(loop (cdr types)
|
||||
(cons (if (fx< (fx+ iint 1) gp-reg-count)
|
||||
(load-double-stack int-reg-offset)
|
||||
(load-split-double-stack int-reg-offset (fx+ stack-arg-offset 4)))
|
||||
locs)
|
||||
(fx+ iint width) iflt (fx+ int-reg-offset size) float-reg-offset
|
||||
(fx+ stack-arg-offset size)
|
||||
next-varargs-after)])))]
|
||||
[(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-ftd& ,ftd) ftd]
|
||||
[else #f])
|
||||
=>
|
||||
(lambda (ftd)
|
||||
(let ([members ($ftd->members ftd)])
|
||||
(cond
|
||||
[(and (not ($ftd-union? ftd))
|
||||
(pair? members)
|
||||
(null? (cdr members))
|
||||
(eq? 'float (caar members))
|
||||
(fx< iflt fp-reg-count))
|
||||
;; single member as float => in register
|
||||
(let ([load-address (case ($ftd-size ftd)
|
||||
[(4) load-stack-address/convert-float]
|
||||
[else load-stack-address])]
|
||||
[size ($ftd-size ftd)])
|
||||
(loop (cdr types)
|
||||
(cons (load-address float-reg-offset) locs)
|
||||
(fx+ iint (fxsrl size 2)) (fx+ iflt 1) (fx+ int-reg-offset size) (fx+ float-reg-offset 8)
|
||||
(fx+ stack-arg-offset size)
|
||||
next-varargs-after))]
|
||||
[(memv ($ftd-size ftd) '(1 2))
|
||||
;; byte or word; need to load address into middle
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack float-reg-offset) locs)
|
||||
(fx+ iint width) (fx+ iflt 1) (fx+ int-reg-offset size) (fx+ float-reg-offset size)
|
||||
(fx+ stack-arg-offset size))]
|
||||
[(or (not varargs?)
|
||||
(fx>= iint gp-reg-count))
|
||||
;; on stack
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack stack-arg-offset) locs)
|
||||
iint iflt int-reg-offset float-reg-offset
|
||||
(fx+ stack-arg-offset size))]
|
||||
[else ;; => varargs
|
||||
;; in integer register --- but maybe halfway on stack
|
||||
(loop (cdr types)
|
||||
(cons (if (fx< (fx+ iint 1) gp-reg-count)
|
||||
(load-double-stack int-reg-offset)
|
||||
(load-split-double-stack int-reg-offset (fx+ stack-arg-offset 4)))
|
||||
(cons (load-stack-address (fx+ (fx- 4 ($ftd-size ftd))
|
||||
(if (< iint gp-reg-count)
|
||||
int-reg-offset
|
||||
stack-arg-offset)))
|
||||
locs)
|
||||
(fx+ iint width) iflt (fx+ int-reg-offset size) float-reg-offset
|
||||
(fx+ stack-arg-offset size))])))]
|
||||
[(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-ftd& ,ftd) ftd]
|
||||
[else #f])
|
||||
=>
|
||||
(lambda (ftd)
|
||||
(let ([members ($ftd->members ftd)])
|
||||
(cond
|
||||
[(and (not ($ftd-union? ftd))
|
||||
(pair? members)
|
||||
(null? (cdr members))
|
||||
(eq? 'float (caar members))
|
||||
(fx< iflt fp-reg-count))
|
||||
;; single member as float => in register
|
||||
(let ([load-address (case ($ftd-size ftd)
|
||||
[(4) load-stack-address/convert-float]
|
||||
[else load-stack-address])]
|
||||
[size ($ftd-size ftd)])
|
||||
(loop (cdr types)
|
||||
(cons (load-address float-reg-offset) locs)
|
||||
(fx+ iint (fxsrl size 2)) (fx+ iflt 1) (fx+ int-reg-offset size) (fx+ float-reg-offset 8)
|
||||
(fx+ stack-arg-offset size)))]
|
||||
[(memv ($ftd-size ftd) '(1 2))
|
||||
;; byte or word; need to load address into middle
|
||||
(loop (cdr types)
|
||||
(cons (load-stack-address (fx+ (fx- 4 ($ftd-size ftd))
|
||||
(if (< iint gp-reg-count)
|
||||
int-reg-offset
|
||||
stack-arg-offset)))
|
||||
locs)
|
||||
(fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset
|
||||
(fx+ stack-arg-offset 4))]
|
||||
[else
|
||||
;; in registers until they run out; copy the registers
|
||||
;; to the reserved space just before arguments that
|
||||
;; are only on the stack, and then we have a contiguous
|
||||
;; object on the stack; except that sizes not a multiple
|
||||
;; of 4 are always on the stack and no copying is needed
|
||||
(let* ([size ($ftd-size ftd)]
|
||||
[words (fxsrl (align 4 size) 2)]
|
||||
[loc
|
||||
(cond
|
||||
[(not (fx= size (fx* words 4)))
|
||||
(load-stack-address stack-arg-offset)]
|
||||
[else
|
||||
(let c-loop ([size size] [iint iint] [offset 0])
|
||||
(cond
|
||||
[(or (fx<= size 0)
|
||||
(fx>= iint gp-reg-count))
|
||||
(fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset
|
||||
(fx+ stack-arg-offset 4)
|
||||
next-varargs-after)]
|
||||
[else
|
||||
;; in registers until they run out; copy the registers
|
||||
;; to the reserved space just before arguments that
|
||||
;; are only on the stack, and then we have a contiguous
|
||||
;; object on the stack; except that sizes not a multiple
|
||||
;; of 4 are always on the stack and no copying is needed
|
||||
(let* ([size ($ftd-size ftd)]
|
||||
[words (fxsrl (align 4 size) 2)]
|
||||
[loc
|
||||
(cond
|
||||
[(not (fx= size (fx* words 4)))
|
||||
(load-stack-address stack-arg-offset)]
|
||||
[else
|
||||
(let ([loc (c-loop (fx- size 4) (fx+ iint 1) (fx+ offset 4))]
|
||||
[tmp %Carg8])
|
||||
(lambda (lvalue)
|
||||
(%seq
|
||||
(set! ,tmp ,(%mref ,%sp ,(fx+ int-reg-offset offset)))
|
||||
(set! ,(%mref ,%sp ,(fx+ stack-arg-offset offset)) ,tmp)
|
||||
,(loc lvalue))))]))])])
|
||||
(loop (cdr types)
|
||||
(cons loc locs)
|
||||
(fx+ iint words) iflt (fx+ int-reg-offset (fx* 4 words)) float-reg-offset
|
||||
(fx+ stack-arg-offset (fx* 4 words))))])))]
|
||||
[(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-integer ,bits) (fx= bits 64)]
|
||||
[(fp-unsigned ,bits) (fx= bits 64)]
|
||||
[else #f])
|
||||
(cond
|
||||
[(fx< (fx+ iint 1) gp-reg-count)
|
||||
(loop (cdr types)
|
||||
(cons (load-int64-stack int-reg-offset) locs)
|
||||
(fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset (fx+ stack-arg-offset 8))]
|
||||
[(fx< iint gp-reg-count)
|
||||
;; split across a register and the stack
|
||||
(loop (cdr types)
|
||||
(cons (load-split-int64-stack int-reg-offset stack-arg-offset) locs)
|
||||
(fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset (fx+ stack-arg-offset 8))]
|
||||
[else
|
||||
(loop (cdr types)
|
||||
(cons (load-int64-stack stack-arg-offset) locs)
|
||||
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))])]
|
||||
[else
|
||||
(if (fx< iint gp-reg-count)
|
||||
(loop (cdr types)
|
||||
(cons (load-int-stack (car types) int-reg-offset) locs)
|
||||
(fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset (fx+ stack-arg-offset 4))
|
||||
(loop (cdr types)
|
||||
(cons (load-int-stack (car types) stack-arg-offset) locs)
|
||||
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))])))))
|
||||
(let c-loop ([size size] [iint iint] [offset 0])
|
||||
(cond
|
||||
[(or (fx<= size 0)
|
||||
(fx>= iint gp-reg-count))
|
||||
(load-stack-address stack-arg-offset)]
|
||||
[else
|
||||
(let ([loc (c-loop (fx- size 4) (fx+ iint 1) (fx+ offset 4))]
|
||||
[tmp %Carg8])
|
||||
(lambda (lvalue)
|
||||
(%seq
|
||||
(set! ,tmp ,(%mref ,%sp ,(fx+ int-reg-offset offset)))
|
||||
(set! ,(%mref ,%sp ,(fx+ stack-arg-offset offset)) ,tmp)
|
||||
,(loc lvalue))))]))])])
|
||||
(loop (cdr types)
|
||||
(cons loc locs)
|
||||
(fx+ iint words) iflt (fx+ int-reg-offset (fx* 4 words)) float-reg-offset
|
||||
(fx+ stack-arg-offset (fx* 4 words))
|
||||
next-varargs-after))])))]
|
||||
[(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-integer ,bits) (fx= bits 64)]
|
||||
[(fp-unsigned ,bits) (fx= bits 64)]
|
||||
[else #f])
|
||||
(cond
|
||||
[(fx< (fx+ iint 1) gp-reg-count)
|
||||
(loop (cdr types)
|
||||
(cons (load-int64-stack int-reg-offset) locs)
|
||||
(fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset (fx+ stack-arg-offset 8)
|
||||
next-varargs-after)]
|
||||
[(fx< iint gp-reg-count)
|
||||
;; split across a register and the stack
|
||||
(loop (cdr types)
|
||||
(cons (load-split-int64-stack int-reg-offset stack-arg-offset) locs)
|
||||
(fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset (fx+ stack-arg-offset 8)
|
||||
next-varargs-after)]
|
||||
[else
|
||||
(loop (cdr types)
|
||||
(cons (load-int64-stack stack-arg-offset) locs)
|
||||
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)
|
||||
next-varargs-after)])]
|
||||
[else
|
||||
(if (fx< iint gp-reg-count)
|
||||
(loop (cdr types)
|
||||
(cons (load-int-stack (car types) int-reg-offset) locs)
|
||||
(fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset (fx+ stack-arg-offset 4)
|
||||
next-varargs-after)
|
||||
(loop (cdr types)
|
||||
(cons (load-int-stack (car types) stack-arg-offset) locs)
|
||||
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)
|
||||
next-varargs-after))]))))))
|
||||
(define count-reg-args
|
||||
(lambda (types gp-reg-count fp-reg-count synthesize-first-argument?)
|
||||
(let f ([types types] [iint (if synthesize-first-argument? -1 0)] [iflt 0])
|
||||
|
|
@ -3248,7 +3255,7 @@
|
|||
;; we push all of the int reg args with one push instruction and all of the
|
||||
;; float reg args with another (v)push instruction
|
||||
(lambda (types gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset
|
||||
synthesize-first-argument? varargs? return-space-offset)
|
||||
synthesize-first-argument? varargs-after return-space-offset)
|
||||
(let loop ([types (if synthesize-first-argument? (cdr types) types)]
|
||||
[locs '()]
|
||||
[iint 0]
|
||||
|
|
@ -3524,7 +3531,8 @@
|
|||
[callee-save-fp-offset (fx+ (fx* isaved 4) callee-save-offset)]
|
||||
[synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)]
|
||||
[adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)]
|
||||
[varargs? (memq 'varargs (info-foreign-conv* info))]
|
||||
[varargs-after (ormap (lambda (conv) (and (pair? conv) (eq? 'varargs (car conv)) (cdr conv)))
|
||||
(info-foreign-conv* info))]
|
||||
[unactivate-mode-offset (fx+ (fx* fpsaved 8) callee-save-fp-offset)]
|
||||
[return-space-offset (align 8 (fx+ unactivate-mode-offset (if adjust-active? 4 0)))]
|
||||
[stack-size (align 16 (fx+ return-space-offset (if synthesize-first-argument? 8 0)))]
|
||||
|
|
@ -3555,7 +3563,7 @@
|
|||
; to the Scheme argument locations
|
||||
(do-stack (indirect-result-to-pointer result-type arg-type*)
|
||||
gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset
|
||||
synthesize-first-argument? varargs? return-space-offset)
|
||||
synthesize-first-argument? varargs-after return-space-offset)
|
||||
get-result
|
||||
(lambda ()
|
||||
(in-context Tail
|
||||
|
|
|
|||
|
|
@ -8934,10 +8934,14 @@
|
|||
[else ($oops '$fp-type->pred "unrecognized type ~s" type)])])))
|
||||
|
||||
(define $filter-conv
|
||||
(lambda (who conv*)
|
||||
(lambda (who conv* num-args)
|
||||
(define squawk
|
||||
(lambda (x)
|
||||
(syntax-error x (format "invalid ~s convention" who))))
|
||||
(define check-arg-count
|
||||
(lambda (n orig-c)
|
||||
(unless (<= n num-args)
|
||||
(syntax-error orig-c (format "invalid ~s convention with ~a arguments" who num-args)))))
|
||||
(let loop ([conv* conv*] [selected #f] [accum '()] [keep-accum '()])
|
||||
(cond
|
||||
[(null? conv*) (datum->syntax #'filter-conv keep-accum)]
|
||||
|
|
@ -8948,7 +8952,17 @@
|
|||
(cond
|
||||
[(not c) (values #f #f)]
|
||||
[(eq? c '__collect_safe) (values 'adjust-active #f)]
|
||||
[(eq? c '__varargs) (values 'varargs #f)]
|
||||
[(eq? c '__varargs)
|
||||
(check-arg-count 1 orig-c)
|
||||
(values (cons 'varargs 1) #f)]
|
||||
[(and (pair? c) (eq? (car c) '__varargs_after)
|
||||
(pair? (cdr c)) (null? (cddr c))
|
||||
(let ([i (cadr c)])
|
||||
(and (integer? i)
|
||||
(exact? i)
|
||||
(positive? i))))
|
||||
(check-arg-count (cadr c) orig-c)
|
||||
(values (cons 'varargs (cadr c)) #f)]
|
||||
[else
|
||||
(values
|
||||
(case ($target-machine)
|
||||
|
|
@ -8964,7 +8978,8 @@
|
|||
[else (squawk orig-c)])]
|
||||
[else (squawk orig-c)])
|
||||
#t)])])
|
||||
(when (member c accum)
|
||||
(when (or (member c accum)
|
||||
(and (pair? c) (ormap pair? accum)))
|
||||
(syntax-error orig-c (format "redundant ~s convention" who)))
|
||||
(when (and select? selected)
|
||||
(syntax-error orig-c (format "conflicting ~s convention" who)))
|
||||
|
|
@ -8979,16 +8994,18 @@
|
|||
(define (check-strings-allowed)
|
||||
(when (memq 'adjust-active (syntax->datum conv*))
|
||||
($oops who "string argument not allowed with __collect_safe procedure")))
|
||||
(define (check-floats-allowed)
|
||||
(when (memq 'varargs (syntax->datum conv*))
|
||||
($oops who "float argument not allowed for __varargs procedure")))
|
||||
(define (check-floats-allowed pos)
|
||||
(let ([va-n (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs) (cdr conv)))
|
||||
(syntax->datum conv*))])
|
||||
(when (and va-n (>= pos va-n))
|
||||
($oops who "single-float varargs argument not allowed"))))
|
||||
(with-syntax ([conv* conv*]
|
||||
[foreign-name foreign-name]
|
||||
[?foreign-addr ?foreign-addr]
|
||||
[(t ...) (generate-temporaries type*)])
|
||||
(with-syntax ([(((check ...) (actual ...) (arg ...)) ...)
|
||||
(map
|
||||
(lambda (type x)
|
||||
(lambda (type x pos)
|
||||
(with-syntax ([x x])
|
||||
(or (case type
|
||||
[(boolean)
|
||||
|
|
@ -9079,7 +9096,7 @@
|
|||
(err ($moi) x)))))
|
||||
(u32*))]
|
||||
[(single-float)
|
||||
(check-floats-allowed)
|
||||
(check-floats-allowed pos)
|
||||
#f]
|
||||
[else #f])
|
||||
(if (or ($ftd? type) ($ftd-as-box? type))
|
||||
|
|
@ -9092,7 +9109,7 @@
|
|||
#`(#,(if unsafe? #'() #'((unless (pred x) (err ($moi) x))))
|
||||
(x)
|
||||
(type)))))))
|
||||
type* #'(t ...))]
|
||||
type* #'(t ...) (enumerate type*))]
|
||||
[(result-filter result)
|
||||
(case result-type
|
||||
[(boolean) #`((lambda (x) (not (eq? x 0)))
|
||||
|
|
@ -9160,7 +9177,7 @@
|
|||
[(_ c ... ?name (arg ...) result)
|
||||
(lambda (r)
|
||||
($make-foreign-procedure 'foreign-procedure
|
||||
($filter-conv 'foreign-procedure #'(c ...))
|
||||
($filter-conv 'foreign-procedure #'(c ...) (length #'(arg ...)))
|
||||
(let ([x (datum ?name)]) (and (string? x) x))
|
||||
#'($foreign-entry ?name)
|
||||
(map (lambda (x) (filter-type r x #f)) #'(arg ...))
|
||||
|
|
@ -9176,13 +9193,15 @@
|
|||
(define (check-strings-allowed)
|
||||
(when (memq 'adjust-active (syntax->datum conv*))
|
||||
($oops who "string result not allowed with __collect_safe callable")))
|
||||
(define (check-floats-allowed)
|
||||
(when (memq 'varargs (syntax->datum conv*))
|
||||
($oops who "float argument not allowed for __varargs procedure")))
|
||||
(define (check-floats-allowed pos)
|
||||
(let ([va-n (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs) (cdr conv)))
|
||||
(syntax->datum conv*))])
|
||||
(when (and va-n (>= pos va-n))
|
||||
($oops who "single-float argument not allowed for __varargs procedure"))))
|
||||
(with-syntax ([conv* conv*] [?proc ?proc])
|
||||
(with-syntax ([((actual (t ...) (arg ...)) ...)
|
||||
(map
|
||||
(lambda (type)
|
||||
(lambda (type pos)
|
||||
(or (case type
|
||||
[(boolean)
|
||||
(with-syntax ([(x) (generate-temporaries #'(*))])
|
||||
|
|
@ -9269,12 +9288,12 @@
|
|||
(x)
|
||||
(unsigned-64)))]
|
||||
[(single-float)
|
||||
(check-floats-allowed)
|
||||
(check-floats-allowed pos)
|
||||
#f]
|
||||
[else #f])
|
||||
(with-syntax ([(x) (generate-temporaries #'(*))])
|
||||
#`(x (x) (#,(datum->syntax #'foreign-callable type))))))
|
||||
type*)]
|
||||
type* (enumerate type*))]
|
||||
[(result-filter result [extra-arg ...] [extra ...])
|
||||
(case result-type
|
||||
[(boolean) #`((lambda (x) (if x 1 0))
|
||||
|
|
@ -9423,7 +9442,7 @@
|
|||
[(_ c ... ?proc (arg ...) result)
|
||||
(lambda (r)
|
||||
($make-foreign-callable 'foreign-callable
|
||||
($filter-conv 'foreign-callable #'(c ...))
|
||||
($filter-conv 'foreign-callable #'(c ...) (length #'(arg ...)))
|
||||
#'?proc
|
||||
(map (lambda (x) (filter-type r x #f)) #'(arg ...))
|
||||
(filter-type r #'result #t)))])))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user