diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 88c13d3..c1de8fc 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -18,7 +18,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \ ikarus.promises.ss ikarus.reader.ss \ ikarus.records.procedural.ss ikarus.conditions.ss \ ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \ - ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \ + ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss \ ikarus.unicode-conversion.ss ikarus.unicode.ss \ ikarus.vectors.ss ikarus.writer.ss makefile.ss \ pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \ diff --git a/scheme/Makefile.in b/scheme/Makefile.in index afac5d8..841ac0d 100644 --- a/scheme/Makefile.in +++ b/scheme/Makefile.in @@ -173,7 +173,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \ ikarus.promises.ss ikarus.reader.ss \ ikarus.records.procedural.ss ikarus.conditions.ss \ ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \ - ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \ + ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss \ ikarus.unicode-conversion.ss ikarus.unicode.ss \ ikarus.vectors.ss ikarus.writer.ss makefile.ss \ pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \ diff --git a/scheme/ikarus.debugger.ss b/scheme/ikarus.debugger.ss index a5cab19..f7b857a 100644 --- a/scheme/ikarus.debugger.ss +++ b/scheme/ikarus.debugger.ss @@ -1,7 +1,9 @@ (library (ikarus.debugger) - (export debug-call guarded-start) - (import (ikarus)) + (export debug-call guarded-start + make-traced-procedure make-traced-macro) + (import (except (ikarus) make-traced-procedure make-traced-macro)) + (define (with-output-to-string/limit x len) (define n 0) @@ -27,13 +29,14 @@ (flush-output-port p)) (substring str 0 n)))) - (define-struct scell (cf ocell prev)) + (define-struct scell (cf ocell trace filter prev)) (define (mkcell prev) - (make-scell #f #f prev)) + (make-scell #f #f #f #f prev)) (define *scell* (mkcell #f)) + (define (stacked-call pre thunk post) (call/cf (lambda (cf) @@ -59,9 +62,67 @@ (define return-handler (lambda v* (set-scell-ocell! *scell* #f) + (cond + [(scell-trace *scell*) => + (lambda (n) + (display-return-trace n ((scell-filter *scell*) v*)))]) (apply values v*))) + (module (display-return-trace make-traced-procedure make-traced-macro) + (define *trace-depth* 0) + + (define display-prefix + (lambda (n) + (let f ([i 0]) + (unless (= i n) + (display (if (even? i) "|" " ")) + (f (+ i 1)))))) + + (define (display-call-trace n ls) + (display-prefix n) + (write ls) + (newline)) + + (define (display-return-trace n ls) + (display-prefix n) + (unless (null? ls) + (write (car ls)) + (let f ([ls (cdr ls)]) + (unless (null? ls) + (write-char #\space) + (write (car ls)) + (f (cdr ls))))) + (newline)) + + (define make-traced-procedure + (case-lambda + [(name proc) (make-traced-procedure name proc (lambda (x) x))] + [(name proc filter) + (lambda args + (stacked-call + (lambda () + (set! *trace-depth* (add1 *trace-depth*))) + (lambda () + (set-scell-trace! *scell* *trace-depth*) + (set-scell-filter! *scell* filter) + (display-call-trace *trace-depth* (filter (cons name args))) + (apply proc args)) + (lambda () + (set! *trace-depth* (sub1 *trace-depth*)))))])) + + (define make-traced-macro + (lambda (name x) + (cond + [(procedure? x) + (make-traced-procedure name x syntax->datum)] + [(variable-transformer? x) + (make-variable-transformer + (make-traced-procedure name + (variable-transformer-procedure x) + syntax->datum))] + [else x])))) + (define-struct trace (src/expr rator rands)) (define (trace-src x) diff --git a/scheme/ikarus.main.ss b/scheme/ikarus.main.ss index dadd6fd..7e51dbe 100644 --- a/scheme/ikarus.main.ss +++ b/scheme/ikarus.main.ss @@ -77,7 +77,7 @@ (import (except (ikarus) load-r6rs-script) (except (ikarus startup) host-info) (only (ikarus.compiler) generate-debug-calls) - (ikarus.debugger) + (only (ikarus.debugger) guarded-start) (only (psyntax library-manager) current-library-expander) (only (ikarus.reader.annotated) read-source-file) (only (ikarus.symbol-table) initialize-symbol-table!) diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index 3027272..97fb8c3 100644 --- a/scheme/ikarus.pointers.ss +++ b/scheme/ikarus.pointers.ss @@ -262,8 +262,8 @@ (die who "failed to initialize" rtype argtypes) (die who "FFI support is not enabled. \ You need to recompile ikarus with \ - --enable-ffi option set in order to \ - make use of the (ikarus foreign) \ + --enable-libffi option set in order \ + to make use of the (ikarus foreign) \ library."))) argtypes-n rtype-n))) diff --git a/scheme/ikarus.trace.ss b/scheme/ikarus.trace.ss deleted file mode 100644 index 9f9e760..0000000 --- a/scheme/ikarus.trace.ss +++ /dev/null @@ -1,213 +0,0 @@ -;;; Ikarus Scheme -- A compiler for R6RS Scheme. -;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License version 3 as -;;; published by the Free Software Foundation. -;;; -;;; This program is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(library (ikarus trace) - (export make-traced-procedure make-traced-macro) - (import (except (ikarus) make-traced-procedure make-traced-macro)) - - - (define-struct scell (cf trace filter prev)) - - (define (mkcell prev) - (make-scell #f #f #f prev)) - - (define *scell* (mkcell #f)) - - (define *trace-depth* 0) - - (define display-prefix - (lambda (n) - (let f ([i 0]) - (unless (= i n) - (display (if (even? i) "|" " ")) - (f (+ i 1)))))) - - (define display-trace - (lambda (k* v) - (display-prefix k* #t) - (write v) - (newline))) - - (define (display-return-trace n ls) - (display-prefix n) - (unless (null? ls) - (write (car ls)) - (let f ([ls (cdr ls)]) - (unless (null? ls) - (write-char #\space) - (write (car ls)) - (f (cdr ls))))) - (newline)) - - (define (display-call-trace n ls) - (display-prefix n) - (write ls) - (newline)) - - (define (stacked-call pre thunk post) - (call/cf - (lambda (cf) - (if (eq? cf (scell-cf *scell*)) - (thunk) - (dynamic-wind - (let ([scell (mkcell *scell*)]) - (lambda () - (set! *scell* scell) - (pre))) - (lambda () - (call-with-values - (lambda () - (call/cf - (lambda (cf) - (set-scell-cf! *scell* cf) - (thunk)))) - return-handler)) - (lambda () - (post) - (set! *scell* (scell-prev *scell*)))))))) - - (define return-handler - (lambda v* - (cond - [(scell-trace *scell*) => - (lambda (n) - (display-return-trace n ((scell-filter *scell*) v*)))]) - (apply values v*))) - - (define make-traced-procedure - (case-lambda - [(name proc) (make-traced-procedure name proc (lambda (x) x))] - [(name proc filter) - (lambda args - (stacked-call - (lambda () - (set! *trace-depth* (add1 *trace-depth*))) - (lambda () - (set-scell-trace! *scell* *trace-depth*) - (set-scell-filter! *scell* filter) - (display-call-trace *trace-depth* (filter (cons name args))) - (apply proc args)) - (lambda () - (set! *trace-depth* (sub1 *trace-depth*)))))])) - - - (define make-traced-macro - (lambda (name x) - (cond - [(procedure? x) - (make-traced-procedure name x syntax->datum)] - [(variable-transformer? x) - (make-variable-transformer - (make-traced-procedure name - (variable-transformer-procedure x) - syntax->datum))] - [else x])))) - - -#!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) - (cond - [(assq s traced-symbols) => - (lambda (pr) - (let ([a (cdr pr)] [v (symbol-value s)]) - (unless (eq? (cdr a) v) - (unless (procedure? v) - (die 'trace - "the top-level value is not a procedure" - s v)) - (let ([p (make-traced-procedure s v)]) - (set-car! a v) - (set-cdr! a p) - (set-symbol-value! s p)))))] - [else - (unless (symbol-bound? s) - (die 'trace "unbound" s)) - (let ([v (symbol-value s)]) - (unless (procedure? v) - (die 'trace "the top-level value is not a procedure" s v)) - (let ([p (make-traced-procedure s v)]) - (set! traced-symbols - (cons (cons s (cons v p)) traced-symbols)) - (set-symbol-value! s p)))]))) -Try: - -(trace-define fact - (lambda (n) - (if (zero? n) - 1 - (* n (fact (sub1 n)))))) -(fact 5) - -(trace-define (fact n m) - (cond - [(zero? n) m] - [else (fact (sub1 n) (* n m))])) -(fact 5 1) - - -(trace-define (fact n m k) - (cond - [(zero? n) (k m)] - [else (begin (fact (sub1 n) (* n m) k) 0)])) - - -(call/cc - (lambda (k) - (fact 6 1 - (trace-lambda escape (v) (k v))))) - - -(call/cc - (lambda k* - (trace-define (fact n) - (cond - [(zero? n) - (call/cc - (lambda (k) - (set! k* (cons k k*)) - 1))] - [else (* n (fact (sub1 n)))])) - (fact 9) - (let ([k (car k*)]) - (set! k* (cdr k*)) - (k 100000)))) - - - - - -(trace-define (infinite-loop n) - (infinite-loop (add1 n))) -(infinite-loop 0) - diff --git a/scheme/last-revision b/scheme/last-revision index 9c514f9..9bbb474 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1784 +1785 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 2358e5b..7cf1764 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -110,7 +110,7 @@ "ikarus.command-line.ss" "ikarus.pointers.ss" "ikarus.not-yet-implemented.ss" - "ikarus.trace.ss" + ;"ikarus.trace.ss" "ikarus.debugger.ss" "ikarus.main.ss" ))