conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added make-traced-procedure, trace-lambda and trace-define.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-13 22:42:48 -04:00
parent 7d46631e14
commit ea28d03f43
4 changed files with 69 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

39
src/ikarus.syntax.ss
View File

@ -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]

49
src/ikarus.trace.ss
View File

@ -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

5
src/makefile.ss
View File

@ -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+ ]
))