331 lines
9.1 KiB
Common Lisp
331 lines
9.1 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: padvise.s
|
||
|
||
; Last Revision: 1-Oct-85 1400ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; David Bartley ;
|
||
; ;
|
||
; MIT Scheme Advisory Procedures ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
(begin
|
||
(define *args*)
|
||
(define *proc*)
|
||
(define *result*)
|
||
(define advise-entry)
|
||
(define advise-exit)
|
||
(define break)
|
||
(define break-both)
|
||
(define break-entry)
|
||
(define break-exit)
|
||
(define trace)
|
||
(define trace-both)
|
||
(define trace-entry)
|
||
(define trace-exit)
|
||
(define unadvise)
|
||
(define unadvise-entry)
|
||
(define unadvise-exit)
|
||
(define unbreak)
|
||
(define unbreak-entry)
|
||
(define unbreak-exit)
|
||
(define untrace)
|
||
(define untrace-entry)
|
||
(define untrace-exit)
|
||
(define %advise-info-vector-list)
|
||
)
|
||
|
||
;;; info-vector format:
|
||
;;;
|
||
;;; 0 : LINK next info-vector / () ** NOT USED **
|
||
;;; 1 : WRAPPER orig closure object with new contents
|
||
;;; 2 : WRAPPEE new closure object with old contents
|
||
;;; 3 : ENTRY-ADVICE list of entry procedures / ()
|
||
;;; 4 : EXIT-ADVICE list of exit procedures / ()
|
||
;;;
|
||
;;; closure object format:
|
||
;;;
|
||
;;; -1 : LENGTH (indices are for use with %REIFY)
|
||
;;; 0 : DEBUG-INFO source, name, etc
|
||
;;; 1 : ENVIRONMENT environment object
|
||
;;; 2 : CB displacement VM address
|
||
;;; 3 : CB offset to entry VM fixnum
|
||
;;; 4 : NARGS fixnum
|
||
|
||
|
||
(letrec
|
||
(
|
||
(*args*value '()) ; *ARGS*VALUE
|
||
(*proc*value '()) ; *PROC*VALUE
|
||
(*result*value '()) ; *RESULT*VALUE
|
||
|
||
(info-vector-list '()) ; INFO-VECTOR-LIST
|
||
|
||
|
||
(add-advice ; ADD-ADVICE
|
||
(lambda (proc advice index)
|
||
(if (and (closure? proc)(closure? advice))
|
||
(let* ((info (get-info-vector proc info-vector-list))
|
||
(advl (vector-ref info index)))
|
||
(when (not (memq advice advl))
|
||
(vector-set! info index
|
||
(cons advice advl)))
|
||
'OK)
|
||
(%error-invalid-operand-list 'ADVISE proc advice))))
|
||
|
||
|
||
(get-info-vector ; GET-INFO-VECTOR
|
||
(lambda (wrappee iv-list)
|
||
(cond ((null? iv-list)
|
||
(let* ((info (make-vector 5 '()))
|
||
(wrapper (make-wrapper info)))
|
||
(set! info-vector-list
|
||
(cons info info-vector-list))
|
||
(swap-closure-contents
|
||
wrapper wrappee 4)
|
||
(vector-set! info 1 ; 1=WRAPPER
|
||
wrappee) ; swap!
|
||
(vector-set! info 2 ; 2=WRAPPEE
|
||
wrapper) ; swap!
|
||
info))
|
||
((eq? wrappee
|
||
(vector-ref (car iv-list) 1)) ; 1=WRAPPER (not WRAPPEE)
|
||
(car iv-list))
|
||
(else
|
||
(get-info-vector wrappee (cdr iv-list))))))
|
||
|
||
|
||
(swap-closure-contents ; SWAP-CLOSURE-CONTENTS
|
||
(lambda (wrapper wrappee index)
|
||
(if (zero? index)
|
||
(%reify! wrapper index ; copy the debug info
|
||
(%reify wrappee index))
|
||
(let ((value (%reify wrapper index)))
|
||
(%reify! wrapper index (%reify wrappee index))
|
||
(%reify! wrappee index value)
|
||
(swap-closure-contents wrapper wrappee (- index 1))))))
|
||
|
||
|
||
(rem-advice ; REM-ADVICE
|
||
(lambda (args ; (proc) -or- () ==> all
|
||
advice ; advice-proc -or- () ==> all
|
||
index) ; 3 -or- 4, entry/exit
|
||
(let ((proc (car args)))
|
||
(when (and proc (not (closure? proc)))
|
||
(apply %error-invalid-operand-list
|
||
(cons 'UNADVISE args)))
|
||
(remove-advice proc advice index
|
||
info-vector-list '())
|
||
'OK)))
|
||
|
||
|
||
(remove-advice ; REMOVE-ADVICE
|
||
(lambda (proc advice index iv-list new-iv-list)
|
||
(if (null? iv-list)
|
||
(set! info-vector-list new-iv-list)
|
||
(let ((info (car iv-list)))
|
||
(cond ((null? proc)
|
||
(vector-set! info index '()))
|
||
((eq? proc (vector-ref info 1))
|
||
(vector-set! info index
|
||
(if (null? advice)
|
||
'()
|
||
(delq! advice
|
||
(vector-ref info index))))))
|
||
(if (or (vector-ref info 3)
|
||
(vector-ref info 4))
|
||
(remove-advice proc advice index
|
||
(cdr iv-list)
|
||
(cons info new-iv-list))
|
||
(begin
|
||
(swap-closure-contents
|
||
(vector-ref info 1) ; 1=WRAPPER
|
||
(vector-ref info 2) ; 2=WRAPPEE
|
||
4)
|
||
(remove-advice proc advice index
|
||
(cdr iv-list)
|
||
new-iv-list)))))))
|
||
|
||
|
||
(make-wrapper ; MAKE-WRAPPER
|
||
(lambda (info-vector)
|
||
(lambda args
|
||
(call/cc
|
||
(fluid-lambda (%*BREAK*continuation)
|
||
(let* ((info info-vector) ; cache INFO-VECTOR
|
||
(proc (vector-ref info 2)) ; 2=WRAPPEE
|
||
(env (procedure-environment proc)))
|
||
(do ((advice (vector-ref info 3) ; 3=ENTRY-ADVICE
|
||
(cdr advice)))
|
||
((null? advice))
|
||
((car advice) proc args env))
|
||
(do ((result (apply proc args)
|
||
((car advice) proc args result env))
|
||
(advice (vector-ref info 4) ; 4=EXIT-ADVICE
|
||
(cdr advice)))
|
||
((null? advice)
|
||
result))))))))
|
||
|
||
|
||
(print-arg-list ; PRINT-ARG-LIST
|
||
(lambda (num args)
|
||
(newline)
|
||
(when args
|
||
(princ " Argument ") (princ num) (princ ": ")
|
||
(prin1 (car args))
|
||
(print-arg-list (+ num 1) (cdr args)))))
|
||
|
||
|
||
(std-break-entry ; STD-BREAK-ENTRY
|
||
(lambda (proc args env)
|
||
(set! *proc*value proc)
|
||
(set! *args*value args)
|
||
(set! *result*value '())
|
||
(breakpoint-procedure 'BREAK-ENTRY
|
||
(cons proc args)
|
||
env
|
||
(%reify-stack
|
||
(+ (%reify-stack
|
||
(+ (%reify-stack -1) 6)) 6)))
|
||
*args*value))
|
||
|
||
|
||
(std-break-exit ; STD-BREAK-EXIT
|
||
(lambda (proc args result env)
|
||
(set! *proc*value proc)
|
||
(set! *args*value args)
|
||
(set! *result*value result)
|
||
(breakpoint-procedure 'BREAK-EXIT
|
||
(list (cons proc args)
|
||
'|-->|
|
||
result)
|
||
env
|
||
(%reify-stack
|
||
(+ (%reify-stack
|
||
(+ (%reify-stack -1) 6)) 6)))
|
||
*result*value))
|
||
|
||
|
||
(std-trace-entry ; STD-TRACE-ENTRY
|
||
(lambda (proc args env)
|
||
(fresh-line)
|
||
(princ " >>> Entering ")
|
||
(prin1 proc)
|
||
(print-arg-list 1 args)
|
||
args))
|
||
|
||
|
||
(std-trace-exit ; STD-TRACE-EXIT
|
||
(lambda (proc args result env)
|
||
(fresh-line)
|
||
(princ " <<< Leaving ")
|
||
(prin1 proc)
|
||
(princ " with value ")
|
||
(prin1 result)
|
||
(print-arg-list 1 args)
|
||
result))
|
||
|
||
) ; --------------------------------------------------------------
|
||
(begin
|
||
|
||
(set! *args* ; *ARGS*
|
||
(lambda () *args*value))
|
||
|
||
(set! *proc* ; *PROC*
|
||
(lambda () *proc*value))
|
||
|
||
(set! *result* ; *RESULT*
|
||
(lambda () *result*value))
|
||
|
||
(set! advise-entry ; ADVISE-ENTRY
|
||
(lambda (proc advice)
|
||
(add-advice proc advice 3)))
|
||
|
||
(set! advise-exit ; ADVISE-EXIT
|
||
(lambda (proc advice)
|
||
(add-advice proc advice 4)))
|
||
|
||
(set! break ; BREAK
|
||
(lambda (proc)
|
||
(add-advice proc std-break-entry 3)))
|
||
|
||
(set! break-both ; BREAK-BOTH
|
||
(lambda (proc)
|
||
(break-entry proc)
|
||
(break-exit proc)))
|
||
|
||
(set! break-entry ; BREAK-ENTRY
|
||
(lambda (proc)
|
||
(add-advice proc std-break-entry 3)))
|
||
|
||
(set! break-exit ; BREAK-EXIT
|
||
(lambda (proc)
|
||
(add-advice proc std-break-exit 4)))
|
||
|
||
(set! trace ; TRACE
|
||
(lambda (proc)
|
||
(add-advice proc std-trace-entry 3)))
|
||
|
||
(set! trace-both ; TRACE-BOTH
|
||
(lambda (proc)
|
||
(trace-entry proc)
|
||
(trace-exit proc)))
|
||
|
||
(set! trace-entry ; TRACE-ENTRY
|
||
(lambda (proc)
|
||
(add-advice proc std-trace-entry 3)))
|
||
|
||
(set! trace-exit ; TRACE-EXIT
|
||
(lambda (proc)
|
||
(add-advice proc std-trace-exit 4)))
|
||
|
||
(set! unadvise ; UNADVISE
|
||
(lambda args
|
||
(rem-advice args '() 3)
|
||
(rem-advice args '() 4)))
|
||
|
||
(set! unadvise-entry ; UNADVISE-ENTRY
|
||
(lambda args
|
||
(rem-advice args '() 3)))
|
||
|
||
(set! unadvise-exit ; UNADVISE-EXIT
|
||
(lambda args
|
||
(rem-advice args '() 4)))
|
||
|
||
(set! unbreak ; UNBREAK
|
||
(lambda args
|
||
(rem-advice args std-break-entry 3)
|
||
(rem-advice args std-break-exit 4)))
|
||
|
||
(set! unbreak-entry ; UNBREAK-ENTRY
|
||
(lambda args
|
||
(rem-advice args std-break-entry 3)))
|
||
|
||
(set! unbreak-exit ; UNBREAK-EXIT
|
||
(lambda args
|
||
(rem-advice args std-break-exit 4)))
|
||
|
||
(set! untrace ; UNTRACE
|
||
(lambda args
|
||
(rem-advice args std-trace-entry 3)
|
||
(rem-advice args std-trace-exit 4)))
|
||
|
||
(set! untrace-entry ; UNTRACE-ENTRY
|
||
(lambda args
|
||
(rem-advice args std-trace-entry 3)))
|
||
|
||
(set! untrace-exit ; UNTRACE-EXIT
|
||
(lambda args
|
||
(rem-advice args std-trace-exit 4)))
|
||
|
||
(set! %advise-info-vector-list ; for debugging ADVISE
|
||
(lambda () info-vector-list))
|
||
|
||
) ; --------------------------------------------------------------
|
||
)
|
||
|