From 82d8184ca90f1a479f88f10385adbfaa056ee40c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 22 Jan 2019 08:48:55 -0700 Subject: [PATCH] cs: initial cut at `procedure-result-arity` --- racket/src/cs/compile-file.ss | 1 + racket/src/cs/rumble/procedure.ss | 8 ++++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index d9892802ba..7ba6d34344 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -45,6 +45,7 @@ (collect 0) (unless (eq? (vector-ref v 0) (vector-ref v 1)) (error 'eq-on-flonum "no"))))) +(check-defined 'procedure-known-single-valued?) ;; ---------------------------------------- diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index c29548aa1a..e1af5fae7d 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -278,7 +278,9 @@ (define/who (procedure-result-arity p) (check who procedure? p) - #f) + (and (#%procedure? p) + (procedure-known-single-valued? p) + 1)) ;; ---------------------------------------- @@ -820,7 +822,8 @@ (define (primitive? v) (or (eq? v make-struct-type-property) - (eq? v make-struct-type))) + (eq? v make-struct-type) + (eq? v car))) (define (primitive-closure? v) #f) @@ -828,6 +831,7 @@ (cond [(eq? prim make-struct-type-property) 3] [(eq? prim make-struct-type) 5] + [(eq? prim car) 1] [else (raise-argument-error 'primitive-result-arity "primitive?" prim)]))