diff --git a/remix/stx0.rkt b/remix/stx0.rkt index ca04bec..da740ce 100644 --- a/remix/stx0.rkt +++ b/remix/stx0.rkt @@ -180,30 +180,87 @@ (remix-cut (#%dot bodies ...)))]))]) ;; xxx actually implement cut with _ or $ as the var accessor -(define-syntax-parameter remix-cut-$ - (λ (stx) - (raise-syntax-error '$ "illegal outside of cut" stx))) +(define-syntax-parameter remix-cut-box + #f) + +(begin-for-syntax + (struct remix-cut-box-st ([round-two? #:mutable] arg-n->id)) + (define (argmax* f l) + (if (empty? l) + #f + (argmax f l))) + (define (remix-cut-box-st->args this-box the-stx-base) + (match-define (remix-cut-box-st _ arg-n->id) this-box) + (define max-arg-n + (argmax* (λ (x) x) (hash-keys arg-n->id))) + (printf "cut box -> args ~v\n" arg-n->id) + (cond + [max-arg-n + (for/list ([i (in-range (add1 max-arg-n))]) + (printf "arg ~v is...\n" i) + (define nr (format-id the-stx-base "cut-arg~a" i)) + (hash-set! arg-n->id i nr) + nr)] + [else + #'()])) + + (define (remix-cut-index->stx index-stx) + (match-define (remix-cut-box-st round-two? arg-n->id) + (syntax-parameter-value #'remix-cut-box)) + (syntax-parse index-stx + ;; xxx support keywords, rest, etc + [n:nat + (let () + (define nv (syntax->datum #'n)) + (define nr + (hash-ref! arg-n->id nv + (λ () + (printf "cut arg needed for index ~v\n" nv) + #t))) + (cond + [round-two? + (printf "really using it ~v\n" nr) + nr] + [else + (printf "not using it ~v\n" nr) + #'(error 'cut)]))]))) + +(define-syntax remix-cut-$ + (singleton-struct + #:property prop:procedure + (λ (_ stx) + (syntax-parse stx + [$:id + (syntax/loc stx + (#%dot $ 0))])) + #:methods gen:dot-transformer + [(define (dot-transform _ stx) + (syntax-parse stx + [(#%dot $:id index:expr) + (quasisyntax/loc stx + #,(remix-cut-index->stx #'index))] + ;; xxx test this + [(#%dot $:id index:expr more:expr ...) + (quasisyntax/loc stx + (#%dot #,(remix-cut-index->stx #'index) more ...))]))])) + +(require (for-syntax (for-syntax racket/base))) (define-syntax (remix-cut stx) (syntax-parse stx [(_ body:expr) (let () + (define this-box (remix-cut-box-st #f (make-hasheq))) (define cut-body-stx - (with-syntax ([this-$ (generate-temporary '$)]) - (syntax/loc stx - (let-syntax ([this-$ - (λ (stx) - (syntax-parse stx - [$:id - (syntax/loc stx - 0)]))]) - (syntax-parameterize ([remix-cut-$ (make-rename-transformer #'this-$)]) - body))))) - (define cut-body-estx - (local-expand cut-body-stx 'expression '())) - (define this-cut-args - '()) + (quasisyntax/loc stx + (syntax-parameterize ([remix-cut-box #,this-box]) + body))) + (local-expand cut-body-stx 'expression '()) + (set-remix-cut-box-st-round-two?! this-box #t) + (define the-stx-base #'body) + (define cut-args (remix-cut-box-st->args this-box the-stx-base)) + (printf "args are ~v\n" cut-args) (quasisyntax/loc stx - (remix-λ #,this-cut-args #,cut-body-estx)))])) + (remix-λ #,cut-args #,cut-body-stx)))])) (define-syntax (remix-cond stx) (syntax-parse stx diff --git a/remix/tests/simple.rkt b/remix/tests/simple.rkt index d95857f..084b337 100644 --- a/remix/tests/simple.rkt +++ b/remix/tests/simple.rkt @@ -128,7 +128,6 @@ (module+ test v11b) -#;#; (def v11c (λ.(+ $ 1) 10)) (module+ test