Skip to content

Instantly share code, notes, and snippets.

@samth

samth/out.linklet

Created March 29, 2019 14:03
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save samth/1aec5a60b5f9af82c4d0df9a8384b52f to your computer and use it in GitHub Desktop.
Save samth/1aec5a60b5f9af82c4d0df9a8384b52f to your computer and use it in GitHub Desktop.
Download ZIP
Raw
out.linklet
;; 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)))))
(print
(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