128 lines
6.0 KiB
Scheme
128 lines
6.0 KiB
Scheme
#lang scheme/base
|
|
(require (for-template scheme/base)
|
|
(for-template mzlib/serialize)
|
|
mzlib/list
|
|
mzlib/serialize)
|
|
(provide make-closure-definition-syntax
|
|
closure->deserialize-name)
|
|
|
|
(define (closure->deserialize-name proc)
|
|
(cdr (first (third (serialize proc)))))
|
|
|
|
(define (make-closure-definition-syntax tag fvars proc)
|
|
(define (make-id str)
|
|
(datum->syntax tag (string->symbol (format str (syntax->datum tag)))))
|
|
(with-syntax ([CLOSURE:deserialize-info (make-id "~a:deserialize-info")]
|
|
[CLOSURE:serialize-info (make-id "~a:serialize-info")]
|
|
[make-CLOSURE (make-id "make-~a")]
|
|
[CLOSURE? (make-id "~a?")]
|
|
[CLOSURE-ref (make-id "~a-ref")]
|
|
[CLOSURE-set! (make-id "~a-set!")]
|
|
[CLOSURE-env (make-id "~a-env")]
|
|
[set-CLOSURE-env! (make-id "set-~a-env!")]
|
|
[struct:CLOSURE (make-id "struct:~a")])
|
|
(values
|
|
(syntax/loc proc make-CLOSURE)
|
|
(list
|
|
(quasisyntax/loc proc
|
|
(define CLOSURE:deserialize-info
|
|
(make-deserialize-info
|
|
|
|
;; make-proc: value ... -> CLOSURE
|
|
(lambda args
|
|
(apply #,(if (null? fvars)
|
|
(syntax/loc proc
|
|
(#%plain-lambda () (#%plain-app make-CLOSURE)))
|
|
(quasisyntax/loc proc
|
|
(#%plain-lambda #,fvars
|
|
(#%plain-app make-CLOSURE
|
|
(#%plain-lambda ()
|
|
(#%plain-app values #,@fvars))))))
|
|
args))
|
|
|
|
;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void))
|
|
(lambda ()
|
|
(let ([new-closure
|
|
#,(if (null? fvars)
|
|
(syntax/loc proc (#%plain-app make-CLOSURE))
|
|
(syntax/loc proc
|
|
(#%plain-app make-CLOSURE
|
|
(#%plain-lambda () (#%plain-app error "closure not initialized")))))])
|
|
(values
|
|
new-closure
|
|
#,(if (null? fvars)
|
|
(syntax/loc proc void)
|
|
(syntax/loc proc
|
|
(#%plain-lambda (clsr)
|
|
(#%plain-app set-CLOSURE-env! new-closure (#%plain-app CLOSURE-env clsr)))))))))))
|
|
|
|
(quasisyntax/loc proc
|
|
(provide CLOSURE:deserialize-info))
|
|
|
|
(quasisyntax/loc proc
|
|
(define CLOSURE:serialize-info
|
|
(make-serialize-info
|
|
|
|
;; to-vector: CLOSURE -> vector
|
|
#,(if (null? fvars)
|
|
(syntax/loc proc (#%plain-lambda (clsr) (#%plain-app vector)))
|
|
(syntax/loc proc
|
|
(#%plain-lambda (clsr)
|
|
(#%plain-app call-with-values
|
|
(#%plain-lambda () (#%plain-app (#%plain-app CLOSURE-env clsr)))
|
|
vector))))
|
|
|
|
;; The serializer id: --------------------
|
|
;(syntax deserialize-info:CLOSURE)
|
|
;; I still don't know what to put here.
|
|
;; oh well.
|
|
;(quote-syntax #,(syntax deserialize-info:CLOSURE))
|
|
(let ([b (identifier-binding (quote-syntax CLOSURE:deserialize-info))])
|
|
(if (list? b)
|
|
(cons 'CLOSURE:deserialize-info (caddr b))
|
|
'CLOSURE:deserialize-info))
|
|
|
|
;; can-cycle?
|
|
#t
|
|
|
|
;; Directory for last-ditch resolution --------------------
|
|
(or (current-load-relative-directory) (current-directory))
|
|
)))
|
|
|
|
(quasisyntax/loc proc
|
|
(define-values (struct:CLOSURE make-CLOSURE CLOSURE?
|
|
#,@(if (null? fvars)
|
|
(syntax/loc proc ())
|
|
(syntax/loc proc (CLOSURE-env set-CLOSURE-env!))))
|
|
(let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
|
|
(make-struct-type
|
|
'#,tag ;; the tag goes here
|
|
#f ; no super type
|
|
#,(if (null? fvars) 0 1)
|
|
0 ; number of auto-fields
|
|
#f ; auto-v
|
|
|
|
; prop-vals:
|
|
(list (cons prop:serializable CLOSURE:serialize-info)
|
|
(cons prop:procedure
|
|
#,(if (null? fvars)
|
|
(quasisyntax/loc proc
|
|
(#%plain-lambda (clsr . args)
|
|
(#%plain-app apply #,proc args)))
|
|
(quasisyntax/loc proc
|
|
(#%plain-lambda (clsr . args)
|
|
(let-values ([#,fvars (#%plain-app
|
|
(#%plain-app CLOSURE-env clsr))])
|
|
(#%plain-app apply #,proc args)))))))
|
|
|
|
#f ; inspector
|
|
|
|
;; the struct apply proc:
|
|
#f)])
|
|
(values struct:CLOSURE make-CLOSURE CLOSURE?
|
|
#,@(if (null? fvars)
|
|
(syntax/loc proc ())
|
|
(syntax/loc proc
|
|
((#%plain-lambda (clsr) (#%plain-app CLOSURE-ref clsr 0))
|
|
(#%plain-lambda (clsr new-env) (#%plain-app CLOSURE-set! clsr 0 new-env)))))))))))))
|