chez-mit/mit/arity.sls

#!r6rs
;;; Copyright © 2016 Federico Beffa
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Code
(library (mit arity)
  (export procedure-name procedure-arity procedure-arity?
          make-procedure-arity procedure-arity-min procedure-arity-max
          procedure-arity-valid? procedure-of-arity?
          guarantee-procedure-of-arity
          guarantee-procedure guarantee-procedure-arity
          thunk? guarantee-thunk)
  (import (rnrs)
          (only (chezscheme) inspect/object make-weak-eq-hashtable
                format errorf))

;;; Guarantors

(define-syntax define-guarantor
  (syntax-rules ()
    ((_ guarantor predicate)
     (define (guarantor obj . ctx)
       (if (predicate obj)
           obj
           (error 'guarantor
                  (format #f "Wrong type argument in context ~a" ctx)
                  obj))))))
  
(define-guarantor guarantee-procedure procedure?)
(define-guarantor guarantee-index-fixnum index-fixnum?)
(define-guarantor guarantee-thunk thunk?)
(define-guarantor guarantee-procedure-arity procedure-arity?)

;;; General utils

(define (memoize-weak f)
  (let ((table (make-weak-eq-hashtable)))
    (lambda (x)
      (let ((previously-computed-result (hashtable-ref table x #f)))
        (or previously-computed-result
            (let ((result (f x)))
              (hashtable-set! table x result)
              result))))))

(define (identity x) x)

;;; Procedures introspection

;; user defined procedures

(define (procedure-code-source p)
  (if (eq? 'procedure ((inspect/object p) 'type))
      (((inspect/object p) 'code) 'source)
      #f))

(define (procedure-code-source-value-eq proc operator)
  (let ((src (procedure-code-source proc)))
    (if src
        (let ((val (src 'value)))
          (and (pair? val) (eq? operator (car val)) val))
        #f)))

(define (lambda-parameter-list p)
  (let ((form (procedure-code-source-value-eq p 'lambda)))
    (and form (cadr form))))

(define (case-lambda-parameter-list p)
  (let ((form (procedure-code-source-value-eq p 'case-lambda)))
    (if form
        (map car (cdr form))
        #f)))

(define make-procedure-arity
  (case-lambda
   ((a-min) (make-procedure-arity a-min a-min #f))
   ((a-min a-max) (make-procedure-arity a-min a-max #f))
   ((a-min a-max simple-ok?)
    (guarantee-index-fixnum a-min 'make-procedure-arity)
    (unless (or (index-fixnum? a-max) (eq? a-max #f))
      (error 'make-procedure-arity "Wrong type max arity: " a-max))
    (if (and simple-ok? (= a-min a-max))
        a-min
        (cons a-min a-max)))))

(define (parameter-list->arity arglist)
  (let loop ((arglist arglist)
             (optionals? #f)
             (required '())
             (optional '()))
    (cond ((null? arglist)
           (let ((arg-min (length required)))
             (make-procedure-arity arg-min (+ arg-min (length optional)))))
          ((symbol? arglist)
           (make-procedure-arity (length required) #f))
          (else
           (loop (cdr arglist) optionals?
                 (if optionals? required (cons (car arglist) required))
                 (if optionals? (cons (car arglist) optional) optional))))))

(define (%arities-union a1 a2)
  (let ((a1-min (procedure-arity-min a1))
        (a1-max (procedure-arity-max a1))
        (a2-min (procedure-arity-min a2))
        (a2-max (procedure-arity-max a2)))
    (let ((a-max (if (or (not a1-max) (not a2-max)) #f (max a1-max a2-max))))
      (make-procedure-arity (min a1-min a2-min) a-max))))

;; XXX: this is of course an approximation, but backed by common-sense.
(define (parameter-lists->union-arity arglists)
  (let ((arities (map parameter-list->arity arglists)))
    (fold-left %arities-union (car arities) (cdr arities))))

;; built-in procedures

;; Since Chez doesn't report the arity of built-in procedures, we
;; construct a database of the functions.
;;
;; These arities were extracted from the R6RS Spec. with
;; '(r6rs-doc-arities-all)' and from the CSUG with
;; '(csug-doc-arities-all)'.  These procedures are located in the file
;; "r6rs-arity.ss".
(define %%r6rs-procedures-arity
  '((dynamic-wind 3 . 3) (call-with-values 2 . 2)
    (values 0 . #f) (call/cc 1 . 1)
    (call-with-current-continuation 1 . 1) (apply 1 . #f)
    (assertion-violation 2 . #f) (error 2 . #f)
    (vector-for-each 2 . #f) (vector-map 2 . #f)
    (vector-fill! 2 . 2) (list->vector 1 . 1)
    (vector->list 1 . 1) (vector-set! 3 . 3) (vector-ref 2 . 2)
    (vector-length 1 . 1) (vector 0 . #f) (make-vector 1 . 2)
    (vector? 1 . 1) (string-copy 1 . 1) (string-for-each 2 . #f)
    (list->string 1 . 1) (string->list 1 . 1)
    (string-append 0 . #f) (substring 3 . 3) (string>=? 2 . #f)
    (string<=? 2 . #f) (string>? 2 . #f) (string<? 2 . #f)
    (string=? 2 . #f) (string-ref 2 . 2) (string-length 1 . 1)
    (string 0 . #f) (make-string 1 . 2) (string? 1 . 1)
    (char>=? 2 . #f) (char<=? 2 . #f) (char>? 2 . #f)
    (char<? 2 . #f) (char=? 2 . #f) (integer->char 1 . 1)
    (char->integer 1 . 1) (char? 1 . 1) (string->symbol 1 . 1)
    (symbol->string 1 . 1) (symbol? 1 . 1) (for-each 2 . #f)
    (map 2 . #f) (list-ref 2 . 2) (list-tail 2 . 2)
    (reverse 1 . 1) (append 0 . #f) (length 1 . 1) (list 0 . #f)
    (list? 1 . 1) (null? 1 . 1) (cddddr 1 . 1) (cdddar 1 . 1)
    (cadr 1 . 1) (caar 1 . 1) (cdr 1 . 1) (car 1 . 1)
    (cons 2 . 2) (pair? 1 . 1) (boolean? 1 . 1) (not 1 . 1)
    (string->number 1 . 2) (number->string 1 . 3) (angle 1 . 1)
    (magnitude 1 . 1) (imag-part 1 . 1) (real-part 1 . 1)
    (make-polar 2 . 2) (make-rectangular 2 . 2) (expt 2 . 2)
    (exact-integer-sqrt 1 . 1) (sqrt 1 . 1) (atan 1 . 2)
    (acos 1 . 1) (asin 1 . 1) (tan 1 . 1) (cos 1 . 1)
    (sin 1 . 1) (log 1 . 2) (exp 1 . 1) (rationalize 2 . 2)
    (round 1 . 1) (truncate 1 . 1) (ceiling 1 . 1) (floor 1 . 1)
    (denominator 1 . 1) (numerator 1 . 1) (lcm 0 . #f)
    (gcd 0 . #f) (mod0 2 . 2) (div0 2 . 2) (div0-and-mod0 2 . 2)
    (mod 2 . 2) (div 2 . 2) (div-and-mod 2 . 2) (abs 1 . 1)
    (/ 1 . #f) (- 1 . #f) (* 0 . #f) (+ 0 . #f) (min 1 . #f)
    (max 1 . #f) (nan? 1 . 1) (infinite? 1 . 1) (finite? 1 . 1)
    (even? 1 . 1) (odd? 1 . 1) (negative? 1 . 1)
    (positive? 1 . 1) (zero? 1 . 1) (>= 2 . #f) (<= 2 . #f)
    (> 2 . #f) (< 2 . #f) (= 2 . #f) (exact 1 . 1)
    (inexact 1 . 1) (inexact? 1 . 1) (exact? 1 . 1)
    (integer-valued? 1 . 1) (rational-valued? 1 . 1)
    (real-valued? 1 . 1) (integer? 1 . 1) (rational? 1 . 1)
    (real? 1 . 1) (complex? 1 . 1) (number? 1 . 1)
    (procedure? 1 . 1) (equal? 2 . 2) (eq? 2 . 2) (eqv? 2 . 2)
    (string-normalize-nfkc 1 . 1) (string-normalize-nfc 1 . 1)
    (string-normalize-nfkd 1 . 1) (string-normalize-nfd 1 . 1)
    (string-ci>=? 2 . #f) (string-ci<=? 2 . #f)
    (string-ci>? 2 . #f) (string-ci<? 2 . #f)
    (string-ci=? 2 . #f) (string-foldcase 1 . 1)
    (string-titlecase 1 . 1) (string-downcase 1 . 1)
    (string-upcase 1 . 1) (char-general-category 1 . 1)
    (char-title-case? 1 . 1) (char-lower-case? 1 . 1)
    (char-upper-case? 1 . 1) (char-whitespace? 1 . 1)
    (char-numeric? 1 . 1) (char-alphabetic? 1 . 1)
    (char-ci>=? 2 . #f) (char-ci<=? 2 . #f) (char-ci>? 2 . #f)
    (char-ci<? 2 . #f) (char-ci=? 2 . #f) (char-foldcase 1 . 1)
    (char-titlecase 1 . 1) (char-downcase 1 . 1)
    (char-upcase 1 . 1) (utf32->string 2 . 2)
    (utf16->string 2 . 2) (utf8->string 1 . 1)
    (string->utf32 1 . 2) (string->utf16 1 . 2)
    (string->utf8 1 . 1)
    (bytevector-ieee-double-native-set! 3 . 3)
    (bytevector-ieee-single-native-set! 3 . 3)
    (bytevector-ieee-double-ref 3 . 3)
    (bytevector-ieee-double-native-ref 2 . 2)
    (bytevector-ieee-single-ref 3 . 3)
    (bytevector-ieee-single-native-ref 2 . 2)
    (bytevector-s64-native-set! 3 . 3)
    (bytevector-u64-native-set! 3 . 3)
    (bytevector-s64-set! 4 . 4) (bytevector-u64-set! 4 . 4)
    (bytevector-s64-native-ref 2 . 2)
    (bytevector-u64-native-ref 2 . 2) (bytevector-s64-ref 3 . 3)
    (bytevector-u64-ref 3 . 3)
    (bytevector-s32-native-set! 3 . 3)
    (bytevector-u32-native-set! 3 . 3)
    (bytevector-s32-set! 4 . 4) (bytevector-u32-set! 4 . 4)
    (bytevector-s32-native-ref 2 . 2)
    (bytevector-u32-native-ref 2 . 2) (bytevector-s32-ref 3 . 3)
    (bytevector-u32-ref 3 . 3)
    (bytevector-s16-native-set! 3 . 3)
    (bytevector-u16-native-set! 3 . 3)
    (bytevector-s16-set! 4 . 4) (bytevector-u16-set! 4 . 4)
    (bytevector-s16-native-ref 2 . 2)
    (bytevector-u16-native-ref 2 . 2) (bytevector-s16-ref 3 . 3)
    (bytevector-u16-ref 3 . 3) (sint-list->bytevector 3 . 3)
    (uint-list->bytevector 3 . 3) (bytevector->sint-list 3 . 3)
    (bytevector->uint-list 3 . 3) (bytevector-sint-set! 5 . 5)
    (bytevector-uint-set! 5 . 5) (bytevector-sint-ref 4 . 4)
    (bytevector-uint-ref 4 . 4) (u8-list->bytevector 1 . 1)
    (bytevector->u8-list 1 . 1) (bytevector-s8-set! 3 . 3)
    (bytevector-u8-set! 3 . 3) (bytevector-s8-ref 2 . 2)
    (bytevector-u8-ref 2 . 2) (bytevector-copy 1 . 1)
    (bytevector=? 2 . 2) (bytevector-length 1 . 1)
    (make-bytevector 1 . 2) (bytevector? 1 . 1)
    (native-endianness 0 . 0) (cons* 0 . #f) (assq 2 . 2)
    (assv 2 . 2) (assoc 2 . 2) (assp 2 . 2) (memq 2 . 2)
    (memv 2 . 2) (member 2 . 2) (memp 2 . 2) (remq 2 . 2)
    (remv 2 . 2) (remove 2 . 2) (remp 2 . 2) (fold-right 3 . #f)
    (fold-left 3 . #f) (partition 2 . 2) (filter 2 . 2)
    (exists 2 . #f) (for-all 2 . #f) (find 2 . 2)
    (vector-sort! 2 . 2) (vector-sort 2 . 2) (list-sort 2 . 2)
    (record-field-mutable? 2 . 2)
    (record-type-field-names 1 . 1) (record-type-opaque? 1 . 1)
    (record-type-sealed? 1 . 1) (record-type-generative? 1 . 1)
    (record-type-uid 1 . 1) (record-type-parent 1 . 1)
    (record-type-name 1 . 1) (record-rtd 1 . 1) (record? 1 . 1)
    (record-mutator 2 . 2) (record-accessor 2 . 2)
    (record-predicate 1 . 1) (record-constructor 1 . 1)
    (record-type-descriptor? 1 . 1) (undefined-violation? 1 . 1)
    (make-undefined-violation 0 . 0)
    (syntax-violation-subform 1 . 1)
    (syntax-violation-form 1 . 1) (syntax-violation? 1 . 1)
    (make-syntax-violation 2 . 2) (lexical-violation? 1 . 1)
    (make-lexical-violation 0 . 0)
    (implementation-restriction-violation? 1 . 1)
    (make-implementation-restriction-violation 0 . 0)
    (non-continuable-violation? 1 . 1)
    (make-non-continuable-violation 0 . 0) (condition-who 1 . 1)
    (who-condition? 1 . 1) (make-who-condition 1 . 1)
    (condition-irritants 1 . 1) (irritants-condition? 1 . 1)
    (make-irritants-condition 1 . 1)
    (assertion-violation? 1 . 1)
    (make-assertion-violation 0 . 0) (violation? 1 . 1)
    (make-violation 0 . 0) (error? 1 . 1) (make-error 0 . 0)
    (serious-condition? 1 . 1) (make-serious-condition 0 . 0)
    (warning? 1 . 1) (make-warning 0 . 0)
    (condition-message 1 . 1) (message-condition? 1 . 1)
    (make-message-condition 1 . 1) (condition-accessor 2 . 2)
    (condition-predicate 1 . 1) (condition? 1 . 1)
    (simple-conditions 1 . 1) (condition 0 . #f)
    (raise-continuable 1 . 1) (raise 1 . 1)
    (with-exception-handler 2 . 2) (delete-file 1 . 1)
    (file-exists? 1 . 1) (exit 0 . 1) (command-line 0 . 0)
    (bitwise-reverse-bit-field 3 . 3)
    (bitwise-rotate-bit-field 4 . 4)
    (bitwise-arithmetic-shift-right 2 . 2)
    (bitwise-arithmetic-shift-left 2 . 2)
    (bitwise-arithmetic-shift 2 . 2)
    (bitwise-copy-bit-field 4 . 4) (bitwise-bit-field 3 . 3)
    (bitwise-copy-bit 3 . 3) (bitwise-bit-set? 2 . 2)
    (bitwise-first-bit-set 1 . 1) (bitwise-length 1 . 1)
    (bitwise-bit-count 1 . 1) (bitwise-if 3 . 3)
    (bitwise-xor 0 . #f) (bitwise-ior 0 . #f)
    (bitwise-and 0 . #f) (bitwise-not 1 . 1)
    (fixnum->flonum 1 . 1) (no-nans-violation? 1 . 1)
    (make-no-nans-violation 1 . 1)
    (no-infinities-violation? 1 . 1)
    (make-no-infinities-violation 1 . 1) (flexpt 2 . 2)
    (flsqrt 1 . 1) (flatan 1 . 2) (flacos 1 . 1) (flasin 1 . 1)
    (fltan 1 . 1) (flcos 1 . 1) (flsin 1 . 1) (fllog 1 . 2)
    (flexp 1 . 1) (flround 1 . 1) (fltruncate 1 . 1)
    (flceiling 1 . 1) (flfloor 1 . 1) (fldenominator 1 . 1)
    (flnumerator 1 . 1) (flmod0 2 . 2) (fldiv0 2 . 2)
    (fldiv0-and-mod0 2 . 2) (flmod 2 . 2) (fldiv 2 . 2)
    (fldiv-and-mod 2 . 2) (flabs 1 . 1) (fl/ 1 . #f)
    (fl- 1 . #f) (fl* 0 . #f) (fl+ 0 . #f) (flmin 1 . #f)
    (flmax 1 . #f) (flnan? 1 . 1) (flinfinite? 1 . 1)
    (flfinite? 1 . 1) (fleven? 1 . 1) (flodd? 1 . 1)
    (flnegative? 1 . 1) (flpositive? 1 . 1) (flzero? 1 . 1)
    (flinteger? 1 . 1) (fl>=? 2 . #f) (fl>? 2 . #f)
    (fl<=? 2 . #f) (fl<? 2 . #f) (fl=? 2 . #f)
    (real->flonum 1 . 1) (flonum? 1 . 1)
    (fxreverse-bit-field 3 . 3) (fxrotate-bit-field 4 . 4)
    (fxarithmetic-shift-right 2 . 2)
    (fxarithmetic-shift-left 2 . 2) (fxarithmetic-shift 2 . 2)
    (fxcopy-bit-field 4 . 4) (fxbit-field 3 . 3)
    (fxcopy-bit 3 . 3) (fxbit-set? 2 . 2)
    (fxfirst-bit-set 1 . 1) (fxlength 1 . 1) (fxbit-count 1 . 1)
    (fxif 3 . 3) (fxxor 0 . #f) (fxior 0 . #f) (fxand 0 . #f)
    (fxnot 1 . 1) (fx*/carry 3 . 3) (fx-/carry 3 . 3)
    (fx+/carry 3 . 3) (fxmod0 2 . 2) (fxdiv0 2 . 2)
    (fxdiv0-and-mod0 2 . 2) (fxmod 2 . 2) (fxdiv 2 . 2)
    (fxdiv-and-mod 2 . 2) (fx- 1 . 2) (fx* 2 . 2) (fx+ 2 . 2)
    (fxmin 1 . #f) (fxmax 1 . #f) (fxeven? 1 . 1) (fxodd? 1 . 1)
    (fxnegative? 1 . 1) (fxpositive? 1 . 1) (fxzero? 1 . 1)
    (fx<=? 2 . #f) (fx>=? 2 . #f) (fx<? 2 . #f) (fx>? 2 . #f)
    (fx=? 2 . #f) (greatest-fixnum 0 . 0) (least-fixnum 0 . 0)
    (fixnum-width 0 . 0) (fixnum? 1 . 1)
    (syntax-violation 3 . 4) (generate-temporaries 1 . 1)
    (datum->syntax 2 . 2) (syntax->datum 1 . 1)
    (free-identifier=? 2 . 2) (bound-identifier=? 2 . 2)
    (identifier? 1 . 1) (make-variable-transformer 1 . 1)
    (symbol-hash 1 . 1) (string-ci-hash 1 . 1)
    (string-hash 1 . 1) (equal-hash 1 . 1)
    (hashtable-mutable? 1 . 1) (hashtable-hash-function 1 . 1)
    (hashtable-equivalence-function 1 . 1)
    (hashtable-entries 1 . 1) (hashtable-keys 1 . 1)
    (hashtable-clear! 1 . 2) (hashtable-copy 1 . 2)
    (hashtable-update! 4 . 4) (hashtable-contains? 2 . 2)
    (hashtable-delete! 2 . 2) (hashtable-set! 3 . 3)
    (hashtable-ref 3 . 3) (hashtable-size 1 . 1)
    (hashtable? 1 . 1) (make-hashtable 2 . 3)
    (make-eqv-hashtable 0 . 1) (make-eq-hashtable 0 . 1)
    (enum-set-projection 2 . 2) (enum-set-complement 1 . 1)
    (enum-set-difference 2 . 2) (enum-set-intersection 2 . 2)
    (enum-set-union 2 . 2) (enum-set=? 2 . 2)
    (enum-set-subset? 2 . 2) (enum-set-member? 2 . 2)
    (enum-set->list 1 . 1) (enum-set-constructor 1 . 1)
    (enum-set-indexer 1 . 1) (enum-set-universe 1 . 1)
    (make-enumeration 1 . 1) (environment 2 . 2) (eval 2 . 2)
    (set-cdr! 2 . 2) (set-car! 2 . 2) (string-fill! 2 . 2)
    (string-set! 3 . 3) (scheme-report-environment 1 . 1)
    (null-environment 1 . 1) (force 1 . 1) (modulo 2 . 2)
    (remainder 2 . 2) (quotient 2 . 2) (inexact->exact 1 . 1)
    (exact->inexact 1 . 1)))

;; some functions have names not allowed by R6RS and the escape
;; sequences confuse Emacs.  Therefore we use the extended read
;; syntax.
#!chezscheme
(define %%csug-procedures-arity
  '((compute-composition 1 . 2) (compute-size 1 . 2)
    (make-object-finder 1 . 3) (inspect/object 1 . 1)
    (inspect 1 . 1) (remove-foreign-entry 1 . 1)
    (load-shared-object 1 . 1) (foreign-address-name 1 . 1)
    (foreign-entry 1 . 1) (foreign-entry? 1 . 1)
    (ftype-pointer->sexpr 1 . 1) (ftype-pointer-ftype 1 . 1)
    (ftype-pointer-address 1 . 1) (foreign-sizeof 1 . 1)
    (foreign-set! 4 . 4) (foreign-ref 3 . 3)
    (foreign-free 1 . 1) (foreign-alloc 1 . 1)
    (foreign-callable-code-object 1 . 1)
    (foreign-callable-entry-point 1 . 1) (process 1 . 1)
    (open-process-ports 1 . 3) (system 1 . 1)
    (top-level-syntax? 1 . 2) (top-level-syntax 1 . 2)
    (define-top-level-syntax 2 . 3) (top-level-mutable? 1 . 2)
    (top-level-bound? 1 . 2) (top-level-value 1 . 2)
    (set-top-level-value! 2 . 3) (define-top-level-value 2 . 3)
    (engine-return 0 . #f) (make-engine 1 . 1)
    (dynamic-wind 3 . 4) (call/1cc 1 . 1) (andmap 2 . #f)
    (ormap 2 . #f) (record-type-descriptor 1 . 1)
    (record? 1 . 2) (record-type-field-decls 1 . 1)
    (record-type-field-names 1 . 1) (record-type-symbol 1 . 1)
    (record-type-name 1 . 1) (record-field-mutable? 2 . 2)
    (record-field-mutator 2 . 2)
    (record-field-accessible? 2 . 2)
    (record-field-accessor 2 . 2) (record-constructor 1 . 1)
    (make-record-type 2 . 3) (record-writer 1 . 2)
    (record-reader 1 . 2) (symbol-hashtable-delete! 2 . 2)
    (symbol-hashtable-cell 3 . 3)
    (symbol-hashtable-update! 4 . 4)
    (symbol-hashtable-contains? 2 . 2)
    (symbol-hashtable-ref 3 . 3) (symbol-hashtable-set! 3 . 3)
    (symbol-hashtable? 1 . 1) (eq-hashtable-delete! 2 . 2)
    (eq-hashtable-cell 3 . 3) (eq-hashtable-update! 4 . 4)
    (eq-hashtable-contains? 2 . 2) (eq-hashtable-ref 3 . 3)
    (eq-hashtable-set! 3 . 3) (eq-hashtable-weak? 1 . 1)
    (eq-hashtable? 1 . 1) (hashtable-weak? 1 . 1)
    (make-weak-eqv-hashtable 1 . 1)
    (make-weak-eq-hashtable 1 . 1) (hashtable-values 1 . 1)
    (hashtable-cell 3 . 3) (merge! 3 . 3) (merge 3 . 3)
    (sort! 2 . 2) (sort 2 . 2) (property-list 1 . 1)
    (remprop 2 . 2) (getprop 2 . 3) (putprop 3 . 3)
    (gensym? 1 . 1) (gensym->unique-string 1 . 1) (gensym 1 . 2)
    (set-box! 2 . 2) (unbox 1 . 1) (box 1 . 1) (box? 1 . 1)
    (bytevector-s56-set! 4 . 4) (bytevector-u56-set! 4 . 4)
    (bytevector-s48-set! 4 . 4) (bytevector-u48-set! 4 . 4)
    (bytevector-s40-set! 4 . 4) (bytevector-u40-set! 4 . 4)
    (bytevector-s24-set! 4 . 4) (bytevector-u24-set! 4 . 4)
    (bytevector-s56-ref 3 . 3) (bytevector-u56-ref 3 . 3)
    (bytevector-s48-ref 3 . 3) (bytevector-u48-ref 3 . 3)
    (bytevector-s40-ref 3 . 3) (bytevector-u40-ref 3 . 3)
    (bytevector-s24-ref 3 . 3) (bytevector-u24-ref 3 . 3)
    (bytevector-truncate! 2 . 2) (s8-list->bytevector 1 . 1)
    (bytevector->s8-list 1 . 1) (bytevector 0 . #f)
    (fxvector-copy 1 . 1) (list->fxvector 1 . 1)
    (fxvector->list 1 . 1) (fxvector-fill! 2 . 2)
    (fxvector-set! 3 . 3) (fxvector-ref 2 . 2)
    (fxvector-length 1 . 1) (make-fxvector 1 . 2)
    (fxvector 0 . #f) (fxvector? 1 . 1)
    (vector-set-fixnum! 3 . 3) (vector-copy 1 . 1)
    (string-truncate! 2 . 2) (substring-fill! 4 . 4)
    (string-copy! 5 . 5) (string-ci>=? 2 . #f)
    (string-ci<=? 2 . #f) (string-ci>? 2 . #f)
    (string-ci<? 2 . #f) (string-ci=? 2 . #f) (string>=? 2 . #f)
    (string<=? 2 . #f) (string>? 2 . #f) (string<? 2 . #f)
    (string=? 2 . #f) (char- 2 . 2) (char-ci>=? 1 . #f)
    (char-ci<=? 1 . #f) (char-ci>? 1 . #f) (char-ci<? 1 . #f)
    (char-ci=? 1 . #f) (char>=? 1 . #f) (char<=? 1 . #f)
    (char>? 1 . #f) (char<? 1 . #f) (char=? 1 . #f)
    (append! 0 . #f) (reverse! 1 . 1) (subst! 3 . 3)
    (substv! 3 . 3) (substq! 3 . 3) (subst 3 . 3) (substv 3 . 3)
    (substq 3 . 3) (remove! 2 . 2) (remv! 2 . 2) (remq! 2 . 2)
    (enumerate 1 . 1) (iota 1 . 1) (make-list 1 . 2)
    (list* 0 . #f) (list-copy 1 . 1) (last-pair 1 . 1)
    (list-head 2 . 2) (atom? 1 . 1)
    (record-constructor-descriptor? 1 . 1) (enum-set? 1 . 1)
    (number->string 1 . 3) (string->number 1 . 2) (atanh 1 . 1)
    (acosh 1 . 1) (asinh 1 . 1) (tanh 1 . 1) (cosh 1 . 1)
    (sinh 1 . 1) (magnitude-squared 1 . 1) (conjugate 1 . 1)
    (nonnegative? 1 . 1) (nonpositive? 1 . 1)
    (integer-length 1 . 1) (isqrt 1 . 1) (expt-mod 3 . 3)
    (sub1 1 . 1) (-1+ 1 . 1) (1- 1 . 1) (add1 1 . 1)
    (1+ 1 . 1) (>= 2 . #f) (<= 2 . #f) (> 2 . #f) (< 2 . #f)
    (= 2 . #f) (random 1 . 1) (fxsra 2 . 2) (fxsrl 2 . 2)
    (fxsll 2 . 2) (fxlogbit1 2 . 2) (fxlogbit0 2 . 2)
    (fxlogtest 2 . 2) (fxlogbit? 2 . 2) (fxlognot 1 . 1)
    (fxlogxor 0 . #f) (fxlogor 0 . #f) (fxlogior 0 . #f)
    (fxlogand 0 . #f) (ash 2 . 2) (logbit1 2 . 2)
    (logbit0 2 . 2) (logtest 2 . 2) (logbit? 2 . 2)
    (lognot 1 . 1) (logxor 0 . #f) (logor 0 . #f)
    (logior 0 . #f) (logand 0 . #f)
    (cfl-magnitude-squared 1 . 1) (cfl-conjugate 1 . 1)
    (cfl/ 1 . #f) (cfl- 1 . #f) (cfl* 0 . #f) (cfl+ 0 . #f)
    (cfl= 0 . #f) (cfl-imag-part 1 . 1) (cfl-real-part 1 . 1)
    (fl-make-rectangular 2 . 2) (fllp 1 . 1)
    (decode-float 1 . 1) (flnonnegative? 1 . 1)
    (flnonpositive? 1 . 1) (fl>= 1 . #f) (fl<= 1 . #f)
    (fl> 1 . #f) (fl< 1 . #f) (fl= 1 . #f)
    (flonum->fixnum 1 . 1) (fxabs 1 . 1) (fxmodulo 2 . 2)
    (fxremainder 2 . 2) (fxquotient 1 . #f) (fx1- 1 . 1)
    (fx1+ 1 . 1) (fx/ 1 . #f) (fx* 0 . #f) (fx- 1 . #f)
    (fx+ 0 . #f) (fxnonnegative? 1 . 1) (fxnonpositive? 1 . 1)
    (fx>= 1 . #f) (fx<= 1 . #f) (fx> 1 . #f) (fx< 1 . #f)
    (fx= 1 . #f) (cflonum? 1 . 1) (ratnum? 1 . 1)
    (bignum? 1 . 1) (path-absolute? 1 . 1) (path-root 1 . 1)
    (path-extension 1 . 1) (path-parent 1 . 1) (path-last 1 . 1)
    (path-rest 1 . 1) (path-first 1 . 1)
    (directory-separator? 1 . 1) (get-mode 1 . 2) (chmod 2 . 2)
    (rename-file 2 . 2) (delete-directory 1 . 2)
    (delete-file 1 . 2) (mkdir 1 . 2)
    (file-modification-time 1 . 2) (file-change-time 1 . 2)
    (file-access-time 1 . 2) (file-symbolic-link? 1 . 1)
    (file-directory? 1 . 2) (file-regular? 1 . 2)
    (file-exists? 1 . 2) (directory-list 1 . 1)
    (fasl-file 2 . 2) (fasl-read 1 . 1) (fasl-write 2 . 2)
    (char-name 1 . 2) (fprintf 2 . #f) (printf 1 . #f)
    (format 1 . #f) (pretty-format 1 . 2) (pretty-file 2 . 2)
    (pretty-print 1 . 2) (string->multibyte 2 . 2)
    (multibyte->string 2 . 2) (open-fd-input/output-port 1 . 3)
    (open-input-output-file 1 . 2) (fresh-line 1 . 1)
    (truncate-file 1 . 2) (truncate-port 1 . 2)
    (block-write 2 . 3) (display-string 1 . 2)
    (put-string-some 2 . 4) (put-bytevector-some 2 . 4)
    (standard-error-port 1 . 2) (standard-output-port 1 . 2)
    (open-fd-output-port 1 . 3) (with-output-to-file 2 . 3)
    (call-with-output-file 2 . 3) (open-output-file 1 . 2)
    (read-token 1 . 1) (block-read 2 . 3) (char-ready? 1 . 1)
    (input-port-ready? 1 . 1) (unget-u8 2 . 2)
    (unget-char 2 . 2) (unread-char 1 . 2)
    (get-bytevector-some! 4 . 4) (get-string-some! 4 . 4)
    (get-string-some 1 . 1) (standard-input-port 1 . 2)
    (open-fd-input-port 1 . 3) (with-input-from-file 2 . 3)
    (call-with-input-file 2 . 3) (open-input-file 1 . 2)
    (port-file-descriptor 1 . 1) (file-port? 1 . 1)
    (with-output-to-string 1 . 1) (get-output-string 1 . 1)
    (with-input-from-string 2 . 2) (open-input-string 1 . 1)
    (port-file-compressed! 1 . 1) (flush-output-port 1 . 1)
    (clear-output-port 1 . 1) (clear-input-port 1 . 1)
    (file-position 1 . 2)
    (port-has-set-port-nonblocking!? 1 . 1)
    (set-port-nonblocking! 2 . 2)
    (port-has-port-nonblocking?? 1 . 1)
    (port-nonblocking? 1 . 1) (port-has-set-port-length!? 1 . 1)
    (set-port-length! 2 . 2) (port-has-port-length? 1 . 1)
    (file-length 1 . 1) (port-length 1 . 1)
    (set-port-name! 2 . 2) (port-name 1 . 1)
    (set-port-eof! 2 . 2) (port-bol? 1 . 1)
    (set-port-bol! 2 . 2) (port-closed? 1 . 1)
    (mark-port-closed! 1 . 1) (port-output-full? 1 . 1)
    (binary-port-output-count 1 . 1)
    (textual-port-output-count 1 . 1) (port-output-count 1 . 1)
    (set-binary-port-output-buffer! 2 . 2)
    (set-binary-port-output-size! 2 . 2)
    (set-binary-port-output-index! 2 . 2)
    (set-textual-port-output-buffer! 2 . 2)
    (set-textual-port-output-size! 2 . 2)
    (set-textual-port-output-index! 2 . 2)
    (set-port-output-buffer! 2 . 2)
    (set-port-output-size! 2 . 2) (set-port-output-index! 2 . 2)
    (binary-port-output-index 1 . 1)
    (binary-port-output-size 1 . 1)
    (binary-port-output-buffer 1 . 1)
    (textual-port-output-index 1 . 1)
    (textual-port-output-size 1 . 1)
    (textual-port-output-buffer 1 . 1) (port-output-index 1 . 1)
    (port-output-size 1 . 1) (port-output-buffer 1 . 1)
    (port-input-empty? 1 . 1) (binary-port-input-count 1 . 1)
    (textual-port-input-count 1 . 1) (port-input-count 1 . 1)
    (set-binary-port-input-buffer! 2 . 2)
    (set-binary-port-input-size! 2 . 2)
    (set-binary-port-input-index! 2 . 2)
    (set-textual-port-input-buffer! 2 . 2)
    (set-textual-port-input-size! 2 . 2)
    (set-textual-port-input-index! 2 . 2)
    (set-port-input-buffer! 2 . 2) (set-port-input-size! 2 . 2)
    (set-port-input-index! 2 . 2)
    (binary-port-input-index 1 . 1)
    (binary-port-input-size 1 . 1)
    (binary-port-input-buffer 1 . 1)
    (textual-port-input-index 1 . 1)
    (textual-port-input-size 1 . 1)
    (textual-port-input-buffer 1 . 1) (port-input-index 1 . 1)
    (port-input-size 1 . 1) (port-input-buffer 1 . 1)
    (port-handler 1 . 1) (make-input/output-port 3 . 3)
    (make-output-port 2 . 2) (make-input-port 2 . 2)
    (transcoder? 1 . 1) (iconv-codec 1 . 1) (utf-16-codec 1 . 1)
    (library-object-filename 1 . 1) (library-requirements 1 . 2)
    (library-exports 1 . 1) (library-version 1 . 1)
    (locate-source 2 . 2) (open-source-file 1 . 1)
    (get-datum/annotations 3 . 3) (syntax->annotation 1 . 1)
    (source-file-descriptor 2 . 2)
    (source-file-descriptor-path 1 . 1)
    (source-file-descriptor-checksum 1 . 1)
    (source-file-descriptor? 1 . 1)
    (make-source-file-descriptor 2 . 3)
    (source-object-sfd 1 . 1) (source-object-efp 1 . 1)
    (source-object-bfp 1 . 1) (source-object? 1 . 1)
    (make-source-object 3 . 3) (annotation-options 1 . 1)
    (annotation-stripped 1 . 1) (annotation-source 1 . 1)
    (annotation-expression 1 . 1) (annotation? 1 . 1)
    (make-annotation 3 . 4) (make-compile-time-value 1 . 1)
    (literal-identifier=? 2 . 2) (syntax-error 1 . #f)
    (datum->syntax-object 2 . 2) (syntax-object->datum 1 . 1)
    (syntax->vector 1 . 1) (syntax->list 1 . 1)
    (remove-registry! 1 . 1) (put-registry! 2 . 2)
    (get-registry 1 . 1) (putenv 2 . 2) (getenv 1 . 1)
    (virtual-register 1 . 1) (set-virtual-register! 2 . 2)
    (make-parameter 1 . 2) (reset-cost-center! 1 . 1)
    (cost-center-time 1 . 1)
    (cost-center-allocation-count 1 . 1)
    (cost-center-instruction-count 1 . 1)
    (with-cost-center 2 . 3) (cost-center? 1 . 1)
    (sstats-print 1 . 2) (sstats-difference 2 . 2)
    (set-sstats-gc-bytes! 2 . 2) (set-sstats-gc-real! 2 . 2)
    (set-sstats-gc-cpu! 2 . 2) (set-sstats-gc-count! 2 . 2)
    (set-sstats-bytes! 2 . 2) (set-sstats-real! 2 . 2)
    (set-sstats-cpu! 2 . 2) (sstats-gc-bytes 1 . 1)
    (sstats-gc-real 1 . 1) (sstats-gc-cpu 1 . 1)
    (sstats-gc-count 1 . 1) (sstats-bytes 1 . 1)
    (sstats-real 1 . 1) (sstats-cpu 1 . 1) (sstats? 1 . 1)
    (make-sstats 7 . 7) (bytes-allocated 1 . 1)
    (display-statistics 1 . 1) (sleep 1 . 1)
    (date-and-time 1 . 1) (date->time-utc 1 . 1)
    (time-utc->date 1 . 2) (date-year-day 1 . 1)
    (date-week-day 1 . 1) (date-zone-offset 1 . 1)
    (date-year 1 . 1) (date-month 1 . 1) (date-day 1 . 1)
    (date-hour 1 . 1) (date-minute 1 . 1) (date-second 1 . 1)
    (date-nanosecond 1 . 1) (date? 1 . 1) (make-date 8 . 8)
    (current-date 1 . 1) (subtract-duration! 2 . 2)
    (subtract-duration 2 . 2) (add-duration! 2 . 2)
    (add-duration 2 . 2) (time-difference! 2 . 2)
    (time-difference 2 . 2) (copy-time 1 . 1) (time>? 2 . 2)
    (time>=? 2 . 2) (time<=? 2 . 2) (time<? 2 . 2)
    (time=? 2 . 2) (set-time-second! 2 . 2)
    (set-time-nanosecond! 2 . 2) (set-time-type! 2 . 2)
    (time-second 1 . 1) (time-nanosecond 1 . 1)
    (time-type 1 . 1) (time? 1 . 1) (make-time 3 . 3)
    (current-time 1 . 1) (transcript-cafe 1 . 1)
    (transcript-on 1 . 1) (abort 1 . 1) (exit 0 . #f)
    (default-prompt-and-read 1 . 1) (new-cafe 1 . 1)
    (profile-query-weight 1 . 1) (profile-load-data 0 . #f)
    (profile-dump-data 1 . 2) (profile-dump-list 1 . 2)
    (profile-dump-html 1 . 2) (with-source-path 3 . 3)
    (expand/optimize 1 . 2) (sc-expand 1 . 2) (expand 1 . 2)
    (strip-fasl-file 3 . 3) (make-boot-header 2 . #f)
    (make-boot-file 2 . #f) (compile-to-file 2 . 3)
    (compile-to-port 2 . 4) (compile-port 2 . 4)
    (compile-whole-library 2 . 2) (compile-whole-program 2 . 3)
    (maybe-compile-program 1 . 2) (maybe-compile-library 1 . 2)
    (maybe-compile-file 1 . 2) (compile-program 1 . 2)
    (compile-library 1 . 2) (compile-script 1 . 2)
    (compile-file 1 . 2) (revisit 1 . 1) (visit 1 . 1)
    (load-program 1 . 2) (load-library 1 . 2) (load 1 . 2)
    (interpret 1 . 2) (compile 1 . 2) (eval 1 . 2)
    (apropos 1 . 2) (apropos-list 1 . 2)
    (environment-symbols 1 . 1) (copy-environment 1 . 3)
    (environment-mutable? 1 . 1) (environment? 1 . 1)
    (register-signal-handler 2 . 2) (set-timer 1 . 1)
    (break 1 . #f) (create-exception-state 1 . 1)
    (default-exception-handler 1 . 1) (display-condition 1 . 2)
    (warningf 2 . #f) (errorf 2 . #f)
    (assertion-violationf 2 . #f) (warning 2 . #f)
    (locked-object? 1 . 1) (unlock-object 1 . 1)
    (lock-object 1 . 1) (bwp-object? 1 . 1) (weak-pair? 1 . 1)
    (weak-cons 2 . 2) (collect 1 . 2) (ee-compose 0 . #f)
    (ee-string-macro 1 . 1) (ee-bind-key 2 . 2)
    (make-thread-parameter 1 . 2) (condition-broadcast 1 . 1)
    (condition-signal 1 . 1) (condition-wait 2 . 2)
    (thread-condition? 1 . 1) (mutex-release 1 . 1)
    (mutex-acquire 1 . 2) (mutex? 1 . 1) (thread? 1 . 1)
    (fork-thread 1 . 1)))
#!r6rs
    
(define %%built-in-procedures-arity
  (append %%r6rs-procedures-arity %%csug-procedures-arity))

(define %built-in-procedures-arity
  (let ((ht (make-eq-hashtable)))
    (for-each (lambda (pair) (hashtable-set! ht (car pair) (cdr pair)))
              %%built-in-procedures-arity)
    ht))

;; if successfull, returns the procedure's name symbol
(define (built-in-procedure? p)
  (cond ((procedure-name p)
         => (lambda (n)
              (and (hashtable-contains? %built-in-procedures-arity n) n)))
        (else #f)))

(define (built-in-procedure-arity p)
  (cond ((built-in-procedure? p)
         => (lambda (n) (hashtable-ref %built-in-procedures-arity n #f)))
        (else #f)))

;; main interface

(define (procedure-name f)
  (let ((name (((inspect/object (guarantee-procedure f)) 'code) 'name)))
    (if (string? name)
        (string->symbol name)
        #f)))

;; returns (min . max/#f) MIT/Scheme style.
(define procedure-arity
  (memoize-weak
   (lambda (p)
     (guarantee-procedure p 'procedure-arity)
     (cond
      ((lambda-parameter-list p) => parameter-list->arity)
      ((case-lambda-parameter-list p) => parameter-lists->union-arity)
      ((built-in-procedure-arity p) => identity)
      (else
       (error 'procedure-arity "Can't determine arity" p))))))

(define index-fixnum? fixnum?)

(define (simple-arity? object)
  (index-fixnum? object))

(define (general-arity? object)
  (and (pair? object)
       (index-fixnum? (car object))
       (if (cdr object)
           (and (index-fixnum? (cdr object))
                (fx>=? (cdr object) (car object)))
           #t)))

(define (procedure-arity? object)
  (if (simple-arity? object)
      #t
      (general-arity? object)))

(define (procedure-arity-max arity)
  (cond ((simple-arity? arity) arity)
        ((general-arity? arity) (cdr arity))
        (else (error 'procedure-arity-max
                     "Argument isn't a procedure arity" arity))))

(define (procedure-arity-min arity)
  (cond ((simple-arity? arity) arity)
        ((general-arity? arity) (car arity))
        (else (error 'procedure-arity-min
                     "Argument isn't a procedure arity" arity))))

(define (procedure-arity-valid? procedure n-arguments)
  (guarantee-index-fixnum n-arguments 'PROCEDURE-ARITY-VALID?)
  (let ((arity (procedure-arity procedure)))
    (and (<= (car arity) n-arguments)
         (or (not (cdr arity))
             (<= n-arguments (cdr arity))))))

(define (procedure-of-arity? proc arity)
  (and (procedure? proc) (procedure-arity-valid? proc arity)))

(define (guarantee-procedure-of-arity proc arity caller)
  (if (procedure-of-arity? proc arity)
      proc
      (errorf caller "Wrong number of arguments: ~a" arity)))

(define (thunk? proc) (procedure-of-arity? proc 0))

)