* Added make-traced-procedure, trace-lambda and trace-define.
This commit is contained in:
parent
7d46631e14
commit
ea28d03f43
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -794,6 +794,43 @@
|
|||
(bless `(letrec ([,f (lambda ,lhs* ,b . ,b*)])
|
||||
(,f . ,rhs*)))
|
||||
(stx-error stx "invalid syntax"))])))
|
||||
(define trace-lambda-macro
|
||||
(lambda (stx)
|
||||
(syntax-match stx ()
|
||||
[(_ who (fmls ...) b b* ...)
|
||||
(if (valid-bound-ids? fmls)
|
||||
(bless `(make-traced-procedure ',who
|
||||
(lambda ,fmls ,b . ,b*)))
|
||||
(stx-error stx "invalid formals"))]
|
||||
[(_ who (fmls ... . last) b b* ...)
|
||||
(if (valid-bound-ids? (cons last fmls))
|
||||
(bless `(make-traced-procedure ',who
|
||||
(lambda (,@fmls . ,last) ,b . ,b*)))
|
||||
(stx-error stx "invalid formals"))])))
|
||||
(define trace-define-macro
|
||||
(lambda (stx)
|
||||
(syntax-match stx ()
|
||||
[(_ (who fmls ...) b b* ...)
|
||||
(if (valid-bound-ids? fmls)
|
||||
(bless `(define ,who
|
||||
(make-traced-procedure ',who
|
||||
(lambda ,fmls ,b . ,b*))))
|
||||
(stx-error stx "invalid formals"))]
|
||||
[(_ (who fmls ... . last) b b* ...)
|
||||
(if (valid-bound-ids? (cons last fmls))
|
||||
(bless `(define ,who
|
||||
(make-traced-procedure ',who
|
||||
(lambda (,@fmls . ,last) ,b . ,b*))))
|
||||
(stx-error stx "invalid formals"))]
|
||||
[(_ who expr)
|
||||
(if (id? who)
|
||||
(bless `(define ,who
|
||||
(let ([v ,expr])
|
||||
(if (procedure? v)
|
||||
(make-traced-procedure ',who v)
|
||||
(error 'trace-define
|
||||
"~s is not a procedure" v)))))
|
||||
(stx-error stx "invalid formals"))])))
|
||||
(define time-macro
|
||||
(lambda (stx)
|
||||
(syntax-match stx ()
|
||||
|
@ -1667,6 +1704,8 @@
|
|||
[(delay) delay-macro]
|
||||
[(assert) assert-macro]
|
||||
[(endianness) endianness-macro]
|
||||
[(trace-lambda) trace-lambda-macro]
|
||||
[(trace-define) trace-define-macro]
|
||||
[(... => _ else unquote unquote-splicing
|
||||
unsyntax unsyntax-splicing)
|
||||
incorrect-usage-macro]
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(library (ikarus trace)
|
||||
(export make-traced-procedure trace-symbol! untrace-symbol!)
|
||||
(import (ikarus))
|
||||
(export make-traced-procedure)
|
||||
(import (except (ikarus) make-traced-procedure))
|
||||
|
||||
(define k* '())
|
||||
|
||||
|
@ -53,7 +53,29 @@
|
|||
(apply values v*))))
|
||||
(lambda () (set! k* (cdr k*))))]))))))
|
||||
|
||||
(define traced-symbols '())
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
#!eof
|
||||
|
||||
(define traced-symbols '())
|
||||
|
||||
(define untrace-symbol!
|
||||
(lambda (s)
|
||||
(define loop
|
||||
(lambda (ls)
|
||||
(cond
|
||||
[(null? ls) '()]
|
||||
[(eq? s (caar ls))
|
||||
(let ([a (cdar ls)])
|
||||
(when (eq? (cdr a) (symbol-value s))
|
||||
(set-symbol-value! s (car a)))
|
||||
(cdr ls))]
|
||||
[else (cons (car ls) (loop (cdr ls)))])))
|
||||
(set! traced-symbols (loop traced-symbols))))
|
||||
|
||||
(define trace-symbol!
|
||||
(lambda (s)
|
||||
|
@ -81,27 +103,6 @@
|
|||
(set! traced-symbols
|
||||
(cons (cons s (cons v p)) traced-symbols))
|
||||
(set-symbol-value! s p)))])))
|
||||
|
||||
(define untrace-symbol!
|
||||
(lambda (s)
|
||||
(define loop
|
||||
(lambda (ls)
|
||||
(cond
|
||||
[(null? ls) '()]
|
||||
[(eq? s (caar ls))
|
||||
(let ([a (cdar ls)])
|
||||
(when (eq? (cdr a) (symbol-value s))
|
||||
(set-symbol-value! s (car a)))
|
||||
(cdr ls))]
|
||||
[else (cons (car ls) (loop (cdr ls)))])))
|
||||
(set! traced-symbols (loop traced-symbols))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
#!eof
|
||||
|
||||
|
||||
Try:
|
||||
|
||||
(trace-define fact
|
||||
|
|
|
@ -124,6 +124,8 @@
|
|||
[unquote-splicing (macro . unquote-splicing)]
|
||||
[unsyntax (macro . unsyntax)]
|
||||
[unsyntax-splicing (macro . unsyntax-splicing)]
|
||||
[trace-lambda (macro . trace-lambda)]
|
||||
[trace-define (macro . trace-define)]
|
||||
))
|
||||
|
||||
(define library-legend
|
||||
|
@ -262,6 +264,8 @@
|
|||
[unquote-splicing i r ne]
|
||||
[unsyntax i r]
|
||||
[unsyntax-splicing i r]
|
||||
[trace-lambda i]
|
||||
[trace-define i]
|
||||
))
|
||||
|
||||
(define ikarus-procedures-map
|
||||
|
@ -932,6 +936,7 @@
|
|||
[syntax-dispatch ]
|
||||
[make-promise ]
|
||||
[force i]
|
||||
[make-traced-procedure i]
|
||||
[error@fx+ ]
|
||||
|
||||
))
|
||||
|
|
Loading…
Reference in New Issue