(module action-util mzscheme (require (lib "plt-match.ss") "timestamp.ss" "action.ss" "pool.ss" "require.ss") (require-contracts) (require-equiv) (require-mz:class) (define action=? (make-equiv (add-equiv-rule/leaf handle? handle=? default-equiv-rules))) (define initial-stack-frame (make-stack-frame 0 #f #f)) (define (action-source action) (stack-frame-control (action-control-in action))) (define (action-target action) (cond [(new? action) (new-object action)] [(call? action) (call-receiver action)] [(return? action) (stack-frame-control (action-control-out action))] [(get? action) (get-receiver action)] [(set? action) (set-receiver action)] [(inspect? action) (inspect-receiver action)])) (define (spec->action pool prev spec) (let* ([time (if prev (+ (action-timestamp prev) 1) 0)] [frame (if prev (action-control-out prev) initial-stack-frame)]) (match spec [(list 'new object fields) (make-new time frame frame (pool-lookup pool object) (map (match-lambda [`(,name ,value) (list name (pool-lookup pool value))]) fields))] [(list 'call receiver method args) (let* ([obj (pool-lookup pool receiver)]) (make-call time frame (make-stack-frame (+ time 1) obj frame) obj method (map (lambda (arg) (pool-lookup pool arg)) args)))] [(list 'return returned-values) (make-return time frame (stack-frame-previous frame) (map (lambda (value) (pool-lookup pool value)) returned-values))] [(list 'get receiver field) (make-get time frame frame (pool-lookup pool receiver) field)] [(list 'set receiver field value) (make-set time frame frame (pool-lookup pool receiver) field (pool-lookup pool value))] [(list 'inspect receiver) (make-inspect time frame frame (pool-lookup pool receiver))]))) (provide/contract [action=? (action? action? . -> . boolean?)] [action-source (action? . -> . (optional/c object-handle?))] [action-target (action? . -> . (optional/c object-handle?))] [initial-stack-frame stack-frame?] [spec->action (pool? (optional/c action?) spec/c . -> . action?)]) )