129 lines
5.1 KiB
Racket
129 lines
5.1 KiB
Racket
#lang racket/base
|
|
(require racket/list
|
|
syntax/free-vars
|
|
racket/syntax
|
|
(for-template
|
|
racket/base
|
|
racket/serialize)
|
|
"util.rkt")
|
|
|
|
(define (define-closure! label fvars stx)
|
|
; Boxes
|
|
(define make-CLOSURE-box
|
|
(syntax-local-lift-expression
|
|
(quasisyntax/loc stx
|
|
(box (lambda (env) (error 'make-CLOSURE "Closure<~.s> not initialized" '#,label))))))
|
|
(define CLOSURE-set-env!-box
|
|
(syntax-local-lift-expression
|
|
(quasisyntax/loc stx
|
|
(box (lambda (clsr new-env) (error 'CLOSURE-set-env! "Closure<~.s> not initialized" '#,label))))))
|
|
(define CLOSURE-env-box
|
|
(syntax-local-lift-expression
|
|
(quasisyntax/loc stx
|
|
(box (lambda (clsr) (error 'CLOSURE-env "Closure<~.s> not initialized" '#,label))))))
|
|
; Define the deserializer (req closure struct values under lambdas)
|
|
(define CLOSURE:deserialize-info-id
|
|
(syntax-local-lift-expression
|
|
(quasisyntax/loc stx
|
|
(make-deserialize-info
|
|
|
|
;; make-proc: value ... -> CLOSURE
|
|
(lambda args
|
|
(apply (#%plain-lambda #,fvars
|
|
((unbox #,make-CLOSURE-box) (#%plain-lambda () (values #,@fvars))))
|
|
args))
|
|
|
|
;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void))
|
|
(lambda ()
|
|
(let ([new-closure
|
|
((unbox #,make-CLOSURE-box)
|
|
(#%plain-lambda () (error 'deserialize "closure not initialized")))])
|
|
(values
|
|
new-closure
|
|
(#%plain-lambda (clsr)
|
|
((unbox #,CLOSURE-set-env!-box) new-closure ((unbox #,CLOSURE-env-box) clsr))))))))))
|
|
; Define the serializer (req closure struct values + deserializer identifier)
|
|
(define CLOSURE:serialize-info-id
|
|
(syntax-local-lift-expression
|
|
(quasisyntax/loc stx
|
|
(make-serialize-info
|
|
|
|
;; to-vector: CLOSURE -> vector
|
|
(#%plain-lambda (clsr)
|
|
(#%plain-app call-with-values
|
|
(#%plain-lambda () (((unbox #,CLOSURE-env-box) clsr)))
|
|
vector))
|
|
|
|
;; The serializer id: --------------------
|
|
(quote-syntax #,CLOSURE:deserialize-info-id)
|
|
|
|
;; can-cycle?
|
|
#t
|
|
|
|
;; Directory for last-ditch resolution --------------------
|
|
(or (current-load-relative-directory) (current-directory))))))
|
|
; Define the closure struct (req serialize info value)
|
|
(define fun-name
|
|
(or (syntax-local-name) (generate-temporary)))
|
|
(define-values
|
|
(make-CLOSURE-id CLOSURE?-id CLOSURE-env-id CLOSURE-set-env!-id)
|
|
(apply
|
|
values
|
|
(syntax-local-lift-values-expression
|
|
4
|
|
(quasisyntax/loc stx
|
|
(letrec-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
|
|
(make-struct-type
|
|
'#,label ;; the tag goes here
|
|
#f ; no super type
|
|
1
|
|
0 ; number of auto-fields
|
|
#f ; auto-v
|
|
|
|
; prop-vals:
|
|
(list
|
|
(cons prop:serializable #,CLOSURE:serialize-info-id)
|
|
(cons prop:procedure
|
|
(make-keyword-procedure
|
|
(lambda (kws kw-vals clsr . rst)
|
|
(let-values ([#,fvars ((CLOSURE-ref clsr 0))])
|
|
(let ([#,fun-name #,stx])
|
|
(keyword-apply #,fun-name
|
|
kws kw-vals
|
|
rst)))))))
|
|
|
|
#f ; inspector
|
|
|
|
;; the struct apply proc:
|
|
#f)]
|
|
[(CLOSURE-env)
|
|
(#%plain-lambda (clsr) (CLOSURE-ref clsr 0))]
|
|
[(CLOSURE-set-env!)
|
|
(#%plain-lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))])
|
|
(set-box! #,CLOSURE-env-box CLOSURE-env)
|
|
(set-box! #,CLOSURE-set-env!-box CLOSURE-set-env!)
|
|
(set-box! #,make-CLOSURE-box make-CLOSURE)
|
|
(values make-CLOSURE CLOSURE? CLOSURE-env CLOSURE-set-env!))))))
|
|
; Provide the deserializer (req deserializer identifier)
|
|
(syntax-local-lift-provide
|
|
(quasisyntax/loc stx
|
|
#,CLOSURE:deserialize-info-id))
|
|
(values make-CLOSURE-id CLOSURE?-id CLOSURE-env-id))
|
|
|
|
(define (make-closure stx)
|
|
(syntax-case stx ()
|
|
[(_ label lambda-stx)
|
|
(let*-values
|
|
([(lambda-fe-stx) (local-expand #'lambda-stx 'expression empty)]
|
|
[(fvars) (free-vars (disarm lambda-fe-stx))]
|
|
; Define the closure struct (req serialize info value)
|
|
[(make-CLOSURE-id CLOSURE?-id CLOSURE-env-id)
|
|
(define-closure! #'label fvars lambda-fe-stx)])
|
|
; Instantiate the closure
|
|
(quasisyntax/loc stx
|
|
(#,make-CLOSURE-id (#%plain-lambda () (values #,@fvars)))))]))
|
|
|
|
(provide
|
|
make-closure
|
|
define-closure!)
|