Created
March 29, 2019 14:03
-
-
Save samth/1aec5a60b5f9af82c4d0df9a8384b52f to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; This is not the original source code. Instead, this is the code after | |
;; fully expanding and flattening into a single linklet. | |
(module out '#%kernel | |
(define-values | |
(prop:keyword-impersonator keyword-impersonator? keyword-impersonator-ref) | |
(make-struct-type-property 'keyword-impersonator)) | |
(define-values | |
(keyword-procedure-impersonator-of) | |
(lambda (v_0) | |
(begin (if (keyword-impersonator? v_0) (let-values () ((keyword-impersonator-ref v_0) v_0)) (let-values () #f))))) | |
(define-values | |
(struct:keyword-procedure mk-kw-proc keyword-procedure? keyword-procedure-ref keyword-procedure-set!) | |
(make-struct-type | |
'keyword-procedure | |
#f | |
4 | |
0 | |
#f | |
(list (cons prop:checked-procedure #t) (cons prop:impersonator-of keyword-procedure-impersonator-of)) | |
(current-inspector) | |
#f | |
'(0 1 2 3))) | |
(define-values (keyword-procedure-checker) (make-struct-field-accessor keyword-procedure-ref 0)) | |
(define-values (keyword-procedure-proc) (make-struct-field-accessor keyword-procedure-ref 1)) | |
(define-values (keyword-procedure-required) (make-struct-field-accessor keyword-procedure-ref 2)) | |
(define-values (keyword-procedure-allowed) (make-struct-field-accessor keyword-procedure-ref 3)) | |
(define-values | |
(struct:keyword-method make-km keyword-method? km-ref km-set!) | |
(make-struct-type 'procedure struct:keyword-procedure 0 0 #f (list (cons prop:method-arity-error #t)))) | |
(define-values | |
(generate-arity-string) | |
(lambda (proc_0) | |
(begin | |
(let-values (((req_0 allowed_0) (procedure-keywords proc_0)) | |
((a_0) (procedure-arity proc_0)) | |
((keywords-desc_0) | |
(lambda (opt_0 req_1) | |
(begin | |
'keywords-desc | |
(format | |
"~a with keyword~a~a" | |
(if (null? (cdr req_1)) (format "an ~aargument" opt_0) (format "~aarguments" opt_0)) | |
(if (null? (cdr req_1)) "" "s") | |
(let-values (((tmp_0) (length req_1))) | |
(if (equal? tmp_0 1) | |
(let-values () (format " ~a" (car req_1))) | |
(if (equal? tmp_0 2) | |
(let-values () (format " ~a and ~a" (car req_1) (cadr req_1))) | |
(let-values () | |
((letrec-values (((loop_0) | |
(lambda (req_2) | |
(begin | |
'loop | |
(if (null? (cdr req_2)) | |
(format " and ~a" (car req_2)) | |
(format " ~a,~a" (car req_2) (loop_0 (cdr req_2)))))))) | |
loop_0) | |
req_1))))))))) | |
((method-adjust_0) | |
(lambda (a_1) | |
(begin | |
'method-adjust | |
(if (let-values (((or-part_0) (okm? proc_0))) (if or-part_0 or-part_0 (keyword-method? proc_0))) | |
(if (zero? a_1) 0 (sub1 a_1)) | |
a_1))))) | |
(string-append | |
(if (number? a_0) | |
(let-values () (let-values (((a_2) (method-adjust_0 a_0))) (format "~a" a_2))) | |
(if (arity-at-least? a_0) | |
(let-values () | |
(let-values (((a_3) (method-adjust_0 (arity-at-least-value a_0)))) (format "at least ~a" a_3))) | |
(let-values () "a different number"))) | |
(if (null? req_0) "" (format " plus ~a" (keywords-desc_0 "" req_0))) | |
(if allowed_0 | |
(let-values (((others_0) | |
((letrec-values (((loop_1) | |
(lambda (req_3 allowed_1) | |
(begin | |
'loop | |
(if (null? req_3) | |
(let-values () allowed_1) | |
(if (eq? (car req_3) (car allowed_1)) | |
(let-values () (loop_1 (cdr req_3) (cdr allowed_1))) | |
(let-values () | |
(cons (car allowed_1) (loop_1 req_3 (cdr allowed_1)))))))))) | |
loop_1) | |
req_0 | |
allowed_0))) | |
(if (null? others_0) "" (format " plus ~a" (keywords-desc_0 "optional " others_0)))) | |
" plus arbitrary keyword arguments")))))) | |
(define-values | |
(struct:okp make-optional-keyword-procedure okp? okp-ref okp-set!) | |
(make-struct-type | |
'procedure | |
struct:keyword-procedure | |
1 | |
0 | |
#f | |
(list (cons prop:arity-string generate-arity-string)) | |
(current-inspector) | |
0)) | |
(define-values | |
(struct:okm make-optional-keyword-method okm? okm-ref okm-set!) | |
(make-struct-type 'procedure struct:okp 0 0 #f (list (cons prop:method-arity-error #t)))) | |
(define-values | |
(prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name+fail) | |
(make-struct-type-property 'named-keyword-procedure)) | |
(define-values | |
(prop:procedure-accessor procedure-accessor? procedure-accessor-ref) | |
(make-struct-type-property | |
'procedure | |
(lambda (v_1 info-l_0) (if (exact-integer? v_1) (make-struct-field-accessor (list-ref info-l_0 3) v_1) #f)))) | |
(define-values | |
(new-prop:procedure new-procedure? new-procedure-ref) | |
(make-struct-type-property | |
'procedure | |
#f | |
(list (cons prop:procedure values) (cons prop:procedure-accessor values)) | |
#t)) | |
(define-values | |
(struct:keyword-procedure-impersonator make-kpp keyword-procedure-impersonator? kpp-ref kpp-set!) | |
(make-struct-type | |
'procedure | |
struct:keyword-procedure | |
1 | |
0 | |
#f | |
(list (cons prop:keyword-impersonator (lambda (v_2) (kpp-ref v_2 0)))))) | |
(define-values | |
(struct:keyword-method-impersonator make-kmp keyword-method-impersonator? kmp-ref kmp-set!) | |
(make-struct-type | |
'procedure | |
struct:keyword-method | |
1 | |
0 | |
#f | |
(list (cons prop:keyword-impersonator (lambda (v_3) (kmp-ref v_3 0)))))) | |
(define-values | |
(struct:okpp make-optional-keyword-procedure-impersonator okpp? okpp-ref okpp-set!) | |
(make-struct-type | |
'procedure | |
struct:okp | |
1 | |
0 | |
#f | |
(list (cons prop:keyword-impersonator (lambda (v_4) (okpp-ref v_4 0)))))) | |
(define-values | |
(struct:okmp make-optional-keyword-method-impersonator okmp? okmp-ref okmp-set!) | |
(make-struct-type | |
'procedure | |
struct:okp | |
1 | |
0 | |
#f | |
(list (cons prop:keyword-impersonator (lambda (v_5) (okmp-ref v_5 0)))))) | |
(define-values | |
(struct:keyword-procedure/arity-error make-kp/ae kp/ae? kp/ae-ref kp/ae-set!) | |
(make-struct-type | |
'procedure | |
struct:keyword-procedure | |
0 | |
0 | |
#f | |
(list (cons prop:arity-string generate-arity-string) (cons prop:incomplete-arity #t)))) | |
(define-values | |
(struct:keyword-method/arity-error make-km/ae km/ae? km/ae-ref km/ae-set!) | |
(make-struct-type | |
'procedure | |
struct:keyword-method | |
0 | |
0 | |
#f | |
(list (cons prop:arity-string generate-arity-string) (cons prop:incomplete-arity #t)))) | |
(define-values | |
(struct:keyword-procedure-impersonator/arity-error make-kpi/ae kpi/ae? kpi/ae-ref kpi/ae-set!) | |
(make-struct-type | |
'procedure | |
struct:keyword-procedure-impersonator | |
0 | |
0 | |
#f | |
(list (cons prop:arity-string generate-arity-string) (cons prop:incomplete-arity #t)))) | |
(define-values | |
(struct:keyword-method-impersonator/arity-error make-kmi/ae kmi/ae? kmi/ae-ref kmi/ae-set!) | |
(make-struct-type | |
'procedure | |
struct:keyword-method-impersonator | |
0 | |
0 | |
#f | |
(list (cons prop:arity-string generate-arity-string) (cons prop:incomplete-arity #t)))) | |
(define-values | |
(make-required) | |
(lambda (name_0 fail-proc_0 method?_0 impersonator?_0) | |
(begin | |
(let-values (((s:_0 mk_0 ?_0 -ref_0 -set!_0) | |
(make-struct-type | |
(let-values (((or-part_1) name_0)) (if or-part_1 or-part_1 'unknown)) | |
(if impersonator?_0 | |
(if method?_0 | |
struct:keyword-method-impersonator/arity-error | |
struct:keyword-procedure-impersonator/arity-error) | |
(if method?_0 struct:keyword-method/arity-error struct:keyword-procedure/arity-error)) | |
0 | |
0 | |
#f | |
(list (cons prop:named-keyword-procedure (cons name_0 fail-proc_0))) | |
(current-inspector) | |
fail-proc_0))) | |
mk_0)))) | |
(define-values | |
(make-keyword-procedure) | |
(case-lambda | |
((proc_1) (begin (make-keyword-procedure proc_1 (lambda args_0 (apply proc_1 null null args_0))))) | |
((proc_2 plain-proc_0) | |
(make-optional-keyword-procedure | |
(make-keyword-checker null #f (if (procedure? proc_2) (procedure-arity-mask proc_2) #f)) | |
proc_2 | |
null | |
#f | |
plain-proc_0)))) | |
(define-values | |
(keyword-apply) | |
(lambda (proc_3 kws_0 kw-vals_0 normal-args_0 . normal-argss_0) | |
(begin | |
(let-values (((type-error_0) | |
(lambda (what_0 which_0) | |
(begin | |
'type-error | |
(apply | |
raise-argument-error | |
'keyword-apply | |
what_0 | |
which_0 | |
proc_3 | |
kws_0 | |
kw-vals_0 | |
normal-args_0 | |
normal-argss_0))))) | |
(begin | |
(if (procedure? proc_3) (void) (let-values () (type-error_0 "procedure?" 0))) | |
((letrec-values (((loop_2) | |
(lambda (ks_0) | |
(begin | |
'loop | |
(if (null? ks_0) | |
(let-values () (void)) | |
(if (let-values (((or-part_2) (not (pair? ks_0)))) | |
(if or-part_2 or-part_2 (not (keyword? (car ks_0))))) | |
(let-values () (type-error_0 "(listof keyword?)" 1)) | |
(if (null? (cdr ks_0)) | |
(let-values () (void)) | |
(if (let-values (((or-part_3) (not (pair? (cdr ks_0))))) | |
(if or-part_3 or-part_3 (not (keyword? (cadr ks_0))))) | |
(let-values () (loop_2 (cdr ks_0))) | |
(if (keyword<? (car ks_0) (cadr ks_0)) | |
(let-values () (loop_2 (cdr ks_0))) | |
(let-values () | |
(type-error_0 "(and/c (listof? keyword?) sorted? distinct?)" 1))))))))))) | |
loop_2) | |
kws_0) | |
(if (list? kw-vals_0) (void) (let-values () (type-error_0 "list?" 2))) | |
(if (= (length kws_0) (length kw-vals_0)) | |
(void) | |
(let-values () | |
(raise-arguments-error | |
'keyword-apply | |
"keyword list length does not match value list length" | |
"keyword list length" | |
(length kws_0) | |
"value list length" | |
(length kw-vals_0) | |
"keyword list" | |
kws_0 | |
"value list" | |
kw-vals_0))) | |
(let-values (((normal-args_1) | |
((letrec-values (((loop_3) | |
(lambda (normal-argss_1 pos_0) | |
(begin | |
'loop | |
(if (null? (cdr normal-argss_1)) | |
(let-values (((l_0) (car normal-argss_1))) | |
(if (list? l_0) l_0 (type-error_0 "list?" pos_0))) | |
(cons | |
(car normal-argss_1) | |
(loop_3 (cdr normal-argss_1) (add1 pos_0)))))))) | |
loop_3) | |
(cons normal-args_0 normal-argss_0) | |
3))) | |
(if (null? kws_0) | |
(apply proc_3 normal-args_1) | |
(apply | |
(keyword-procedure-extract/method kws_0 (+ 2 (length normal-args_1)) proc_3 0) | |
kws_0 | |
kw-vals_0 | |
normal-args_1)))))))) | |
(define-values | |
(procedure-keywords) | |
(lambda (p_0) | |
(begin | |
(if (keyword-procedure? p_0) | |
(let-values () (values (keyword-procedure-required p_0) (keyword-procedure-allowed p_0))) | |
(if (procedure? p_0) | |
(let-values () | |
(if (new-procedure? p_0) | |
(let-values (((v_6) (new-procedure-ref p_0))) | |
(if (procedure? v_6) | |
(procedure-keywords v_6) | |
(let-values (((a_4) (procedure-accessor-ref p_0))) | |
(if a_4 (procedure-keywords (a_4 p_0)) (values null null))))) | |
(values null null))) | |
(let-values () (raise-argument-error 'procedure-keywords "procedure?" p_0))))))) | |
(define-values | |
(missing-kw) | |
(lambda (proc_4 . args_1) (begin (apply (keyword-procedure-extract/method null 0 proc_4 0) null null args_1)))) | |
(define-values | |
(check-kw-args) | |
(lambda (p_1 kws_1) | |
(begin | |
((letrec-values (((loop_4) | |
(lambda (kws_2 required_0 allowed_2) | |
(begin | |
'loop | |
(if (null? kws_2) | |
(let-values () (if (null? required_0) (values #f #f) (values (car required_0) #f))) | |
(if (if (pair? required_0) (eq? (car required_0) (car kws_2)) #f) | |
(let-values () (loop_4 (cdr kws_2) (cdr required_0) (if allowed_2 (cdr allowed_2) #f))) | |
(if (not allowed_2) | |
(let-values () (loop_4 (cdr kws_2) required_0 #f)) | |
(if (pair? allowed_2) | |
(let-values () | |
(if (eq? (car allowed_2) (car kws_2)) | |
(loop_4 (cdr kws_2) required_0 (cdr allowed_2)) | |
(loop_4 kws_2 required_0 (cdr allowed_2)))) | |
(let-values () (values #f (car kws_2))))))))))) | |
loop_4) | |
kws_1 | |
(keyword-procedure-required p_1) | |
(keyword-procedure-allowed p_1))))) | |
(define-values | |
(make-keyword-checker) | |
(lambda (req-kws_0 allowed-kws_0 arity-mask_0) | |
(begin | |
(let-values () | |
(if (not allowed-kws_0) | |
(let-values () | |
(if (null? req-kws_0) | |
(let-values () (lambda (kws_3 a_5) (bitwise-bit-set? arity-mask_0 a_5))) | |
(let-values () | |
(lambda (kws_4 a_6) (if (subset? req-kws_0 kws_4) (bitwise-bit-set? arity-mask_0 a_6) #f))))) | |
(if (null? allowed-kws_0) | |
(let-values () (lambda (kws_5 a_7) (if (null? kws_5) (bitwise-bit-set? arity-mask_0 a_7) #f))) | |
(let-values () | |
(if (null? req-kws_0) | |
(let-values () | |
(lambda (kws_6 a_8) (if (subset? kws_6 allowed-kws_0) (bitwise-bit-set? arity-mask_0 a_8) #f))) | |
(let-values () | |
(if (if (list? req-kws_0) | |
(if (list? allowed-kws_0) (eq? (length req-kws_0) (length allowed-kws_0)) #f) | |
#f) | |
(lambda (kws_7 a_9) | |
(if ((letrec-values (((loop_5) | |
(lambda (kws_8 req-kws_1) | |
(begin | |
'loop | |
(if (null? req-kws_1) | |
(null? kws_8) | |
(if (null? kws_8) | |
#f | |
(if (eq? (car kws_8) (car req-kws_1)) | |
(loop_5 (cdr kws_8) (cdr req-kws_1)) | |
#f))))))) | |
loop_5) | |
kws_7 | |
req-kws_0) | |
(bitwise-bit-set? arity-mask_0 a_9) | |
#f)) | |
(lambda (kws_9 a_10) | |
(if (subsets? req-kws_0 kws_9 allowed-kws_0) (bitwise-bit-set? arity-mask_0 a_10) #f)))))))))))) | |
(define-values | |
(subset?) | |
(lambda (l1_0 l2_0) | |
(begin | |
(if (null? l1_0) | |
(let-values () #t) | |
(if (null? l2_0) | |
(let-values () #f) | |
(if (eq? (car l1_0) (car l2_0)) | |
(let-values () (subset? (cdr l1_0) (cdr l2_0))) | |
(let-values () (subset? l1_0 (cdr l2_0))))))))) | |
(define-values | |
(subsets?) | |
(lambda (l1_1 l2_1 l3_0) | |
(begin | |
(if (null? l1_1) | |
(let-values () (subset? l2_1 l3_0)) | |
(if (null? l2_1) | |
(let-values () #f) | |
(if (null? l3_0) | |
(let-values () #f) | |
(let-values () | |
(let-values (((v2_0) (car l2_1))) | |
(if (eq? (car l1_1) v2_0) | |
(let-values () (subsets? (cdr l1_1) (cdr l2_1) (cdr l3_0))) | |
(if (eq? v2_0 (car l3_0)) | |
(let-values () (subsets? l1_1 (cdr l2_1) (cdr l3_0))) | |
(let-values () (subsets? l1_1 l2_1 (cdr l3_0))))))))))))) | |
(define-values | |
(keyword-procedure-extract/method) | |
(lambda (kws_10 n_0 p_2 method-n_0) | |
(begin | |
(if (if (keyword-procedure? p_2) ((keyword-procedure-checker p_2) kws_10 n_0) #f) | |
(keyword-procedure-proc p_2) | |
(let-values (((p2_0) | |
(if (not (keyword-procedure? p_2)) | |
(if (procedure? p_2) | |
(let-values (((or-part_4) | |
(if (new-procedure? p_2) | |
(let-values (((a_11) (procedure-accessor-ref p_2))) (if a_11 (a_11 p_2) #f)) | |
#f))) | |
(if or-part_4 | |
or-part_4 | |
(let-values (((or-part_5) (procedure-extract-target p_2))) | |
(if or-part_5 or-part_5 (if (new-procedure? p_2) 'method #f))))) | |
#f) | |
#f))) | |
(if p2_0 | |
(if (eq? p2_0 'method) | |
(let-values (((p3_0) | |
(keyword-procedure-extract/method | |
kws_10 | |
(add1 n_0) | |
(new-procedure-ref p_2) | |
(add1 method-n_0)))) | |
(lambda (kws_11 kw-args_0 . args_2) (apply p3_0 kws_11 kw-args_0 (cons p_2 args_2)))) | |
(keyword-procedure-extract/method kws_10 n_0 p2_0 method-n_0)) | |
(lambda (kws_12 kw-args_1 . args_3) | |
(let-values (((missing-kw_0 extra-kw_0) | |
(if (keyword-procedure? p_2) (check-kw-args p_2 kws_12) (values #f (car kws_12))))) | |
(let-values (((n_1) | |
(let-values (((method-n_1) | |
(+ | |
method-n_0 | |
(if (let-values (((or-part_6) (keyword-method? p_2))) | |
(if or-part_6 or-part_6 (okm? p_2))) | |
1 | |
0)))) | |
(if (>= n_0 method-n_1) (- n_0 method-n_1) n_0))) | |
((args-str_0) | |
(if (if (null? args_3) (null? kws_12) #f) | |
"" | |
(apply | |
string-append | |
"\n arguments...:" | |
(append | |
(map (lambda (v_7) (format "\n ~e" v_7)) args_3) | |
(map | |
(lambda (kw_0 kw-arg_0) (format "\n ~a ~e" kw_0 kw-arg_0)) | |
kws_12 | |
kw-args_1))))) | |
((proc-name_0) | |
(lambda (p_3) | |
(begin | |
'proc-name | |
(let-values (((or-part_7) | |
(if (named-keyword-procedure? p_3) | |
(car (keyword-procedure-name+fail p_3)) | |
#f))) | |
(if or-part_7 | |
or-part_7 | |
(let-values (((or-part_8) (object-name p_3))) (if or-part_8 or-part_8 p_3)))))))) | |
(raise | |
(exn:fail:contract | |
(if extra-kw_0 | |
(if (keyword-procedure? p_2) | |
(format | |
(string-append | |
"application: procedure does not expect an argument with given keyword\n" | |
" procedure: ~a\n" | |
" given keyword: ~a" | |
"~a") | |
(proc-name_0 p_2) | |
extra-kw_0 | |
args-str_0) | |
(if (procedure? p_2) | |
(format | |
(string-append | |
"application: procedure does not accept keyword arguments\n" | |
" procedure: ~a" | |
"~a") | |
(proc-name_0 p_2) | |
args-str_0) | |
(format | |
(string-append | |
"application: not a procedure;\n" | |
" expected a procedure that can be applied to arguments\n" | |
" given: ~e" | |
"~a") | |
p_2 | |
args-str_0))) | |
(if missing-kw_0 | |
(format | |
(string-append | |
"application: required keyword argument not supplied\n" | |
" procedure: ~a\n" | |
" required keyword: ~a" | |
"~a") | |
(proc-name_0 p_2) | |
missing-kw_0 | |
args-str_0) | |
(format | |
(string-append | |
"application: no case matching ~a non-keyword argument~a\n" | |
" procedure: ~a" | |
"~a") | |
(- n_1 2) | |
(if (= 1 (- n_1 2)) "" "s") | |
(proc-name_0 p_2) | |
args-str_0))) | |
(current-continuation-marks)))))))))))) | |
(define-values | |
(new:chaperone-procedure) | |
(let-values (((chaperone-procedure_0) | |
(lambda (proc_5 wrap-proc_0 . props_0) | |
(begin | |
'chaperone-procedure | |
(do-chaperone-procedure | |
#f | |
#f | |
chaperone-procedure | |
'chaperone-procedure | |
proc_5 | |
wrap-proc_0 | |
props_0))))) | |
chaperone-procedure_0)) | |
(define-values | |
(new:impersonate-procedure) | |
(let-values (((impersonate-procedure_0) | |
(lambda (proc_6 wrap-proc_1 . props_1) | |
(begin | |
'impersonate-procedure | |
(do-chaperone-procedure | |
#t | |
#f | |
impersonate-procedure | |
'impersonate-procedure | |
proc_6 | |
wrap-proc_1 | |
props_1))))) | |
impersonate-procedure_0)) | |
(define-values | |
(do-chaperone-procedure) | |
(lambda (is-impersonator?_0 self-arg?_0 chaperone-procedure_1 name_1 proc_7 wrap-proc_2 props_2) | |
(begin | |
(let-values (((n-proc_0) (normalize-proc proc_7)) ((n-wrap-proc_0) (normalize-proc wrap-proc_2))) | |
(if (let-values (((or-part_9) (not (keyword-procedure? n-proc_0)))) | |
(if or-part_9 | |
or-part_9 | |
(let-values (((or-part_10) (not (procedure? wrap-proc_2)))) | |
(if or-part_10 or-part_10 (bad-props? props_2))))) | |
(apply chaperone-procedure_1 proc_7 wrap-proc_2 props_2) | |
(begin | |
(chaperone-arity-match-checking self-arg?_0 name_1 proc_7 wrap-proc_2 props_2) | |
(let-values (((kw-chaperone_0) | |
(let-values (((p_4) (keyword-procedure-proc n-wrap-proc_0))) | |
(let-values () | |
(if self-arg?_0 | |
(case-lambda | |
((self-proc_0 kws_13 args_4 . rest_0) | |
(begin | |
'kw-chaperone | |
(call-with-values | |
(lambda () (apply p_4 kws_13 args_4 self-proc_0 rest_0)) | |
(lambda results_0 | |
(let-values (((len_0) (length results_0))) | |
(let-values (((alen_0) (length rest_0))) | |
(begin | |
(if (< len_0 (+ alen_0 1)) | |
(let-values () | |
(raise-arguments-error | |
'|keyword procedure chaperone| | |
"wrong number of results from wrapper procedure" | |
"expected minimum number of results" | |
(+ alen_0 1) | |
"received number of results" | |
len_0 | |
"wrapper procedure" | |
wrap-proc_2)) | |
(void)) | |
(let-values (((num-extra_0) (- len_0 (+ alen_0 1)))) | |
(begin | |
(let-values (((new-args_0) (list-ref results_0 num-extra_0))) | |
(begin | |
(if (if (list? new-args_0) | |
(= (length new-args_0) (length args_4)) | |
#f) | |
(void) | |
(let-values () | |
(raise-arguments-error | |
'|keyword procedure chaperone| | |
(format | |
"expected a list of keyword-argument values as first result~a from wrapper procedure" | |
(if (= len_0 alen_0) | |
"" | |
" (after the result-wrapper procedure or mark specifications)")) | |
"first result" | |
new-args_0 | |
"wrapper procedure" | |
wrap-proc_2))) | |
(for-each | |
(lambda (kw_1 new-arg_0 arg_0) | |
(if is-impersonator?_0 | |
(void) | |
(let-values () | |
(if (chaperone-of? new-arg_0 arg_0) | |
(void) | |
(let-values () | |
(raise-arguments-error | |
'|keyword procedure chaperone| | |
(format | |
"~a keyword result is not a chaperone of original argument from chaperoning procedure" | |
kw_1) | |
"result" | |
new-arg_0 | |
"wrapper procedure" | |
wrap-proc_2)))))) | |
kws_13 | |
new-args_0 | |
args_4))) | |
(let-values (((tmp_1) num-extra_0)) | |
(if (equal? tmp_1 0) | |
(let-values () (apply values kws_13 results_0)) | |
(if (equal? tmp_1 1) | |
(let-values () | |
(apply values (car results_0) kws_13 (cdr results_0))) | |
(let-values () | |
(apply | |
values | |
((letrec-values (((loop_6) | |
(lambda (results_1 c_0) | |
(begin | |
'loop | |
(if (zero? c_0) | |
(cons kws_13 results_1) | |
(cons | |
(car results_1) | |
(loop_6 | |
(cdr results_1) | |
(sub1 c_0)))))))) | |
loop_6) | |
results_0 | |
num-extra_0))))))))))))))) | |
(other_0 (error "shouldn't get here"))) | |
(case-lambda | |
((kws_14 args_5 . rest_1) | |
(begin | |
'kw-chaperone | |
(call-with-values | |
(lambda () (apply p_4 kws_14 args_5 rest_1)) | |
(lambda results_2 | |
(let-values (((len_1) (length results_2))) | |
(let-values (((alen_1) (length rest_1))) | |
(begin | |
(if (< len_1 (+ alen_1 1)) | |
(let-values () | |
(raise-arguments-error | |
'|keyword procedure chaperone| | |
"wrong number of results from wrapper procedure" | |
"expected minimum number of results" | |
(+ alen_1 1) | |
"received number of results" | |
len_1 | |
"wrapper procedure" | |
wrap-proc_2)) | |
(void)) | |
(let-values (((num-extra_1) (- len_1 (+ alen_1 1)))) | |
(begin | |
(let-values (((new-args_1) (list-ref results_2 num-extra_1))) | |
(begin | |
(if (if (list? new-args_1) | |
(= (length new-args_1) (length args_5)) | |
#f) | |
(void) | |
(let-values () | |
(raise-arguments-error | |
'|keyword procedure chaperone| | |
(format | |
"expected a list of keyword-argument values as first result~a from wrapper procedure" | |
(if (= len_1 alen_1) | |
"" | |
" (after the result-wrapper procedure or mark specifications)")) | |
"first result" | |
new-args_1 | |
"wrapper procedure" | |
wrap-proc_2))) | |
(for-each | |
(lambda (kw_2 new-arg_1 arg_1) | |
(if is-impersonator?_0 | |
(void) | |
(let-values () | |
(if (chaperone-of? new-arg_1 arg_1) | |
(void) | |
(let-values () | |
(raise-arguments-error | |
'|keyword procedure chaperone| | |
(format | |
"~a keyword result is not a chaperone of original argument from chaperoning procedure" | |
kw_2) | |
"result" | |
new-arg_1 | |
"wrapper procedure" | |
wrap-proc_2)))))) | |
kws_14 | |
new-args_1 | |
args_5))) | |
(let-values (((tmp_2) num-extra_1)) | |
(if (equal? tmp_2 0) | |
(let-values () (apply values kws_14 results_2)) | |
(if (equal? tmp_2 1) | |
(let-values () | |
(apply values (car results_2) kws_14 (cdr results_2))) | |
(let-values () | |
(apply | |
values | |
((letrec-values (((loop_7) | |
(lambda (results_3 c_1) | |
(begin | |
'loop | |
(if (zero? c_1) | |
(cons kws_14 results_3) | |
(cons | |
(car results_3) | |
(loop_7 | |
(cdr results_3) | |
(sub1 c_1)))))))) | |
loop_7) | |
results_2 | |
num-extra_1))))))))))))))) | |
(other_1 (error "shouldn't get here")))))))) | |
(let-values (((new-proc_0 chap-accessor_0) | |
((letrec-values (((wrap_0) | |
(lambda (proc_8 n-proc_1) | |
(begin | |
'wrap | |
(if (if (not (eq? n-proc_1 proc_8)) (new-procedure? proc_8) #f) | |
(let-values () | |
(let-values (((v_8) (new-procedure-ref proc_8))) | |
(if (exact-integer? v_8) | |
(let-values () | |
(let-values (((acc_0) (procedure-accessor-ref proc_8))) | |
(values | |
(chaperone-struct | |
proc_8 | |
acc_0 | |
(lambda (self_0 sub-proc_0) | |
(let-values (((f_0 acc_1) | |
(wrap_0 | |
sub-proc_0 | |
(normalize-proc sub-proc_0)))) | |
f_0))) | |
acc_0))) | |
(let-values () | |
(let-values (((new-kw-proc_0) | |
((if is-impersonator?_0 | |
impersonate-struct | |
chaperone-struct) | |
(if (okp? n-proc_1) | |
(chaperone-procedure_1 proc_8 wrap-proc_2) | |
proc_8) | |
new-procedure-ref | |
(lambda (self_1 proc_9) | |
((if is-impersonator?_0 | |
new:impersonate-procedure | |
new:chaperone-procedure) | |
proc_9 | |
(make-keyword-procedure | |
(let-values () | |
(let-values () | |
(if self-arg?_0 | |
(lambda (proc-self_0 | |
kws_15 | |
kw-args_2 | |
self_2 | |
. | |
args_6) | |
(let-values (((len_2) | |
(length args_6))) | |
(call-with-values | |
(lambda () | |
(apply | |
kw-chaperone_0 | |
proc-self_0 | |
kws_15 | |
kw-args_2 | |
args_6)) | |
(lambda results_4 | |
(let-values (((r-len_0) | |
(length | |
results_4))) | |
(letrec-values (((list-take_0) | |
(lambda (l_1 | |
n_2) | |
(begin | |
'list-take | |
(if (zero? | |
n_2) | |
null | |
(cons | |
(car | |
l_1) | |
(list-take_0 | |
(cdr | |
l_1) | |
(sub1 | |
n_2)))))))) | |
(if (if (null? | |
'(proc-self)) | |
(= | |
r-len_0 | |
(+ 2 len_2)) | |
#f) | |
(apply | |
values | |
(cadr results_4) | |
self_2 | |
(cddr results_4)) | |
(apply | |
values | |
(let-values (((skip_0) | |
(- | |
r-len_0 | |
len_2))) | |
(append | |
(list-take_0 | |
results_4 | |
(- skip_0 2)) | |
(list | |
(list-ref | |
results_4 | |
(sub1 skip_0)) | |
self_2) | |
(list-tail | |
results_4 | |
skip_0))))))))))) | |
(lambda (kws_16 | |
kw-args_3 | |
self_3 | |
. | |
args_7) | |
(let-values (((len_3) | |
(length args_7))) | |
(call-with-values | |
(lambda () | |
(apply | |
kw-chaperone_0 | |
kws_16 | |
kw-args_3 | |
args_7)) | |
(lambda results_5 | |
(let-values (((r-len_1) | |
(length | |
results_5))) | |
(letrec-values (((list-take_1) | |
(lambda (l_2 | |
n_3) | |
(begin | |
'list-take | |
(if (zero? | |
n_3) | |
null | |
(cons | |
(car | |
l_2) | |
(list-take_1 | |
(cdr | |
l_2) | |
(sub1 | |
n_3)))))))) | |
(if (if (null? '()) | |
(= | |
r-len_1 | |
(+ 2 len_3)) | |
#f) | |
(apply | |
values | |
(cadr results_5) | |
self_3 | |
(cddr results_5)) | |
(apply | |
values | |
(let-values (((skip_1) | |
(- | |
r-len_1 | |
len_3))) | |
(append | |
(list-take_1 | |
results_5 | |
(- skip_1 2)) | |
(list | |
(list-ref | |
results_5 | |
(sub1 skip_1)) | |
self_3) | |
(list-tail | |
results_5 | |
skip_1)))))))))))))))))))) | |
(values new-kw-proc_0 new-procedure-ref)))))) | |
(if (okp? n-proc_1) | |
(let-values () | |
(values | |
(if is-impersonator?_0 | |
((if (okm? n-proc_1) | |
make-optional-keyword-method-impersonator | |
make-optional-keyword-procedure-impersonator) | |
(keyword-procedure-checker n-proc_1) | |
(chaperone-procedure_1 | |
(keyword-procedure-proc n-proc_1) | |
kw-chaperone_0) | |
(keyword-procedure-required n-proc_1) | |
(keyword-procedure-allowed n-proc_1) | |
(chaperone-procedure_1 | |
(okp-ref n-proc_1 0) | |
(okp-ref n-wrap-proc_0 0)) | |
n-proc_1) | |
(chaperone-struct | |
proc_8 | |
keyword-procedure-proc | |
(lambda (self_4 proc_10) | |
(chaperone-procedure_1 proc_10 kw-chaperone_0)) | |
(make-struct-field-accessor okp-ref 0) | |
(lambda (self_5 proc_11) | |
(chaperone-procedure_1 | |
proc_11 | |
(okp-ref n-wrap-proc_0 0))))) | |
keyword-procedure-proc)) | |
(let-values () | |
(values | |
(if is-impersonator?_0 | |
(let-values (((name+fail_0) | |
(keyword-procedure-name+fail n-proc_1))) | |
(let-values (((mk_1) | |
(make-required | |
(car name+fail_0) | |
(cdr name+fail_0) | |
(keyword-method? n-proc_1) | |
#t))) | |
(mk_1 | |
(keyword-procedure-checker n-proc_1) | |
(chaperone-procedure_1 | |
(keyword-procedure-proc n-proc_1) | |
kw-chaperone_0) | |
(keyword-procedure-required n-proc_1) | |
(keyword-procedure-allowed n-proc_1) | |
n-proc_1))) | |
(chaperone-struct | |
n-proc_1 | |
keyword-procedure-proc | |
(lambda (self_6 proc_12) | |
(chaperone-procedure_1 proc_12 kw-chaperone_0)))) | |
keyword-procedure-proc)))))))) | |
wrap_0) | |
proc_7 | |
n-proc_0))) | |
(if (null? props_2) new-proc_0 (apply chaperone-struct new-proc_0 chap-accessor_0 #f props_2)))))))))) | |
(define-values | |
(bad-props?) | |
(lambda (props_3) | |
(begin | |
((letrec-values (((loop_8) | |
(lambda (props_4) | |
(begin | |
'loop | |
(if (null? props_4) | |
(let-values () #f) | |
(if (impersonator-property? (car props_4)) | |
(let-values () | |
(let-values (((props_5) (cdr props_4))) | |
(let-values (((or-part_11) (null? props_5))) | |
(if or-part_11 or-part_11 (loop_8 (cdr props_5)))))) | |
(let-values () #t))))))) | |
loop_8) | |
props_3)))) | |
(define-values | |
(chaperone-arity-match-checking) | |
(lambda (self-arg?_1 name_2 proc_13 wrap-proc_3 props_6) | |
(begin | |
(let-values (((a_12) (procedure-arity proc_13)) | |
((b_0) (procedure-arity wrap-proc_3)) | |
((d_0) (if self-arg?_1 1 0)) | |
((a-req_0 a-allow_0) (procedure-keywords proc_13)) | |
((b-req_0 b-allow_0) (procedure-keywords wrap-proc_3))) | |
(letrec-values (((includes?_0) | |
(lambda (a_13 b_1) | |
(begin | |
'includes? | |
(if (number? b_1) | |
(let-values () | |
(if (number? a_13) | |
(let-values () (= b_1 (+ a_13 d_0))) | |
(if (arity-at-least? a_13) | |
(let-values () (>= b_1 (+ (arity-at-least-value a_13) d_0))) | |
(let-values () (ormap (lambda (a_14) (includes?_0 a_14 b_1)) a_13))))) | |
(if (arity-at-least? b_1) | |
(let-values () | |
(if (number? a_13) | |
(let-values () #f) | |
(if (arity-at-least? a_13) | |
(let-values () | |
(>= (arity-at-least-value b_1) (+ (arity-at-least-value a_13) d_0))) | |
(let-values () (ormap (lambda (a_15) (includes?_0 b_1 a_15)) a_13))))) | |
(let-values () (andmap (lambda (b_2) (includes?_0 a_13 b_2)) b_1)))))))) | |
(begin | |
(if (includes?_0 b_0 a_12) (void) (let-values () (apply chaperone-procedure proc_13 wrap-proc_3 props_6))) | |
(if (subset? b-req_0 a-req_0) | |
(void) | |
(let-values () | |
(raise-arguments-error | |
name_2 | |
"wrapper procedure requires more keywords than original procedure" | |
"wrapper procedure" | |
wrap-proc_3 | |
"original procedure" | |
proc_13))) | |
(if (let-values (((or-part_12) (not b-allow_0))) | |
(if or-part_12 or-part_12 (if a-allow_0 (subset? a-allow_0 b-allow_0) #f))) | |
(void) | |
(let-values () | |
(raise-arguments-error | |
name_2 | |
"wrapper procedure does not accept all keywords of original procedure" | |
"wrapper procedure" | |
wrap-proc_3 | |
"original procedure" | |
proc_13))) | |
(void))))))) | |
(define-values | |
(normalize-proc) | |
(lambda (proc_14) | |
(begin | |
(if (keyword-procedure? proc_14) | |
(let-values () proc_14) | |
(if (new-procedure? proc_14) | |
(let-values () | |
(let-values (((req-kws_2 allowed-kws_1) (procedure-keywords proc_14))) | |
(if (null? allowed-kws_1) | |
proc_14 | |
(make-optional-keyword-procedure | |
(lambda (given-kws_0 given-argc_0) | |
(if (procedure-arity-includes? proc_14 (- given-argc_0 2) #t) | |
(if (let-values (((or-part_13) (not allowed-kws_1))) | |
(if or-part_13 or-part_13 (subset? given-kws_0 allowed-kws_1))) | |
(subset? req-kws_2 given-kws_0) | |
#f) | |
#f)) | |
(lambda (kws_17 kw-args_4 . vals_0) (keyword-apply proc_14 kws_17 kw-args_4 vals_0)) | |
req-kws_2 | |
allowed-kws_1 | |
proc_14)))) | |
(let-values () proc_14)))))) | |
(define-values (print-values) (lambda vs_0 (begin (begin (for-each (current-print) vs_0) (apply values vs_0))))) | |
(define-values | |
(lifted/1.1 lifted/2.1 lifted/3.1 lifted/4.1 lifted/5.1) | |
(make-struct-type | |
'group-rows | |
struct:keyword-procedure/arity-error | |
0 | |
0 | |
#f | |
(list (cons prop:named-keyword-procedure (cons 'group-rows (case-lambda ((self_7) (apply missing-kw self_7 null)))))) | |
(current-inspector) | |
(case-lambda ((self_8) (apply missing-kw self_8 null))))) | |
(define-values (group-rows3.1) (lambda (group1_0) (begin 'group-rows3 (let-values () (let-values () 1))))) | |
(define-values | |
(unpack4.1) | |
(lambda (given-kws_1 given-args_0) | |
(begin 'unpack4 (let-values (((group1_1) (car given-args_0))) (group-rows3.1 group1_1))))) | |
(define-values | |
(group-rows5.1) | |
(lifted/2.1 | |
(lambda (given-kws_2 given-argc_1) | |
(if (= given-argc_1 2) | |
(let-values (((l2_2) given-kws_2)) (if (pair? l2_2) (if (eq? (car l2_2) '#:group) (null? (cdr l2_2)) #f) #f)) | |
#f)) | |
(case-lambda ((given-kws_3 given-args_1) (unpack4.1 given-kws_3 given-args_1))) | |
'(#:group) | |
'(#:group))) | |
(define-values | |
(impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted) | |
(make-impersonator-property 'impersonator-prop:contracted)) | |
(define-values | |
(lifted/18.1 lifted/19.1 lifted/20.1 lifted/21.1 lifted/22.1) | |
(make-struct-type | |
'/home/samth/tmp.rkt:12:22 | |
struct:keyword-procedure/arity-error | |
0 | |
0 | |
#f | |
(list | |
(cons | |
prop:named-keyword-procedure | |
(cons '/home/samth/tmp.rkt:12:22 (case-lambda ((self_9) (apply missing-kw self_9 null)))))) | |
(current-inspector) | |
(case-lambda ((self_10) (apply missing-kw self_10 null))))) | |
(procedure? | |
(new:chaperone-procedure | |
group-rows5.1 | |
(let-values (((core8_0) (lambda (group6_0) (begin 'core8 (let-values (((x_0) group6_0)) (let-values () x_0)))))) | |
(let-values (((unpack9_0) | |
(lambda (given-kws_4 given-args_2) | |
(begin 'unpack9 (let-values (((group6_1) (car given-args_2))) (core8_0 group6_1)))))) | |
(lifted/19.1 | |
(lambda (given-kws_5 given-argc_2) | |
(if (= given-argc_2 2) | |
(let-values (((l2_3) given-kws_5)) | |
(if (pair? l2_3) (if (eq? (car l2_3) '#:group) (null? (cdr l2_3)) #f) #f)) | |
#f)) | |
(case-lambda ((given-kws_6 given-args_3) (unpack9_0 given-kws_6 given-args_3))) | |
'(#:group) | |
'(#:group)))) | |
impersonator-prop:contracted | |
2)))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment