diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index cdc4609..febf4a8 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 3f3da35..02c7681 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -585,6 +585,7 @@ [(constant c) `(quote ,c)] [(prelex) (Var x)] [(primref x) x] + [(known x t) `(known ,(E x) ,(T:description t))] [(conditional test conseq altern) (cons 'if (map E (list test conseq altern)))] [(primcall op arg*) (cons op (map E arg*))] diff --git a/scheme/ikarus.trace.ss b/scheme/ikarus.trace.ss index 9d612fc..be7a221 100644 --- a/scheme/ikarus.trace.ss +++ b/scheme/ikarus.trace.ss @@ -15,8 +15,8 @@ (library (ikarus trace) - (export make-traced-procedure) - (import (except (ikarus) make-traced-procedure)) + (export make-traced-procedure make-traced-macro) + (import (except (ikarus) make-traced-procedure make-traced-macro)) (define k* '()) @@ -32,6 +32,7 @@ (write v) (newline))) + (define make-traced-procedure (case-lambda [(name proc) (make-traced-procedure name proc (lambda (x) x))] @@ -68,7 +69,19 @@ (f (cdr v*)))))) (newline) (apply values v*)))) - (lambda () (set! k* (cdr k*))))]))))]))) + (lambda () (set! k* (cdr k*))))]))))])) + + (define make-traced-macro + (lambda (name x) + (cond + [(procedure? x) + (make-traced-procedure name x)] + [(variable-transformer? x) + (make-variable-transformer + (make-traced-procedure name + (variable-transformer-procedure x) + syntax->datum))] + [else x])))) #!eof diff --git a/scheme/last-revision b/scheme/last-revision index 04cad1a..effd6e7 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1533 +1534 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 6ef7bbc..5556b48 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -166,6 +166,8 @@ [trace-lambda (macro . trace-lambda)] [trace-define (macro . trace-define)] [trace-define-syntax (macro . trace-define-syntax)] + [trace-let-syntax (macro . trace-let-syntax)] + [trace-letrec-syntax (macro . trace-letrec-syntax)] [guard (macro . guard)] [eol-style (macro . eol-style)] [buffer-mode (macro . buffer-mode)] @@ -287,6 +289,8 @@ [trace-lambda i] [trace-define i] [trace-define-syntax i] + [trace-let-syntax i] + [trace-letrec-syntax i] [make-list i] [last-pair i] [bwp-object? i] @@ -577,6 +581,7 @@ [do-stack-overflow ] [make-promise ] [make-traced-procedure i] + [make-traced-macro i] [error@fx+ ] [error@fxarithmetic-shift-left ] [error@fx* ] @@ -1279,6 +1284,8 @@ [generate-temporaries i r sc] [identifier? i r sc] [make-variable-transformer i r sc] + [variable-transformer? i] + [variable-transformer-procedure i] [char-alphabetic? i r uc se] [char-ci<=? i r uc se] [char-ci safe + [(P) (interrupt)] + [(P a . a*) (fixnum-fold-p '> a a*)] + [(E) (interrupt)] + [(E a . a*) (assert-fixnums a a*)]) + +(define-primop fx>= safe + [(P) (interrupt)] + [(P a . a*) (fixnum-fold-p '>= a a*)] + [(E) (interrupt)] + [(E a . a*) (assert-fixnums a a*)]) + +(define-primop fx=? safe + [(P) (interrupt)] + [(P a . a*) (fixnum-fold-p '= a a*)] + [(E) (interrupt)] + [(E a . a*) (assert-fixnums a a*)]) + +(define-primop fx? safe + [(P) (interrupt)] + [(P a . a*) (fixnum-fold-p '> a a*)] + [(E) (interrupt)] + [(E a . a*) (assert-fixnums a a*)]) + +(define-primop fx>=? safe + [(P) (interrupt)] + [(P a . a*) (fixnum-fold-p '>= a a*)] + [(E) (interrupt)] + [(E a . a*) (assert-fixnums a a*)]) + (define-primop - safe [(V a) (interrupt) diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 485755f..495e466 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -23,13 +23,16 @@ eval expand generate-temporaries free-identifier=? bound-identifier=? datum->syntax syntax-error syntax-violation - syntax->datum make-variable-transformer + syntax->datum + make-variable-transformer + variable-transformer? + variable-transformer-procedure compile-r6rs-top-level boot-library-expand null-environment scheme-report-environment interaction-environment ellipsis-map) (import - (except (rnrs) + (except (rnrs) environment environment? identifier? eval generate-temporaries free-identifier=? bound-identifier=? datum->syntax syntax-error @@ -745,6 +748,17 @@ (assertion-violation 'make-variable-transformer "not a procedure" x)))) + (define (variable-transformer? x) + (and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))) + + (define (variable-transformer-procedure x) + (if (variable-transformer? x) + (cdr x) + (assertion-violation + 'variable-transformer-procedure + "not a variable transformer" + x))) + ;;; make-eval-transformer takes an expanded expression, ;;; evaluates it and returns a proper syntactic binding ;;; for the resulting object. @@ -1271,14 +1285,29 @@ (syntax-match stx () ((_ who expr) (if (id? who) - (bless `(define-syntax ,who - (let ((v ,expr)) - (if (procedure? v) - (make-traced-procedure ',who v syntax->datum) - (assertion-violation 'trace-define-syntax - "not a procedure" v))))) + (bless + `(define-syntax ,who + (make-traced-macro ',who ,expr))) (stx-error stx "invalid name")))))) + (define trace-let/rec-syntax + (lambda (who) + (lambda (stx) + (syntax-match stx () + ((_ ((lhs* rhs*) ...) b b* ...) + (if (valid-bound-ids? lhs*) + (let ([rhs* (map (lambda (lhs rhs) + `(make-traced-macro ',lhs ,rhs)) + lhs* rhs*)]) + (bless `(,who ,(map list lhs* rhs*) ,b . ,b*))) + (invalid-fmls-error stx lhs*))))))) + + (define trace-let-syntax-macro + (trace-let/rec-syntax 'let-syntax)) + + (define trace-letrec-syntax-macro + (trace-let/rec-syntax 'letrec-syntax)) + (define guard-macro (lambda (x) (define (gen-clauses con outerk clause*) @@ -2609,6 +2638,8 @@ ((trace-lambda) trace-lambda-macro) ((trace-define) trace-define-macro) ((trace-define-syntax) trace-define-syntax-macro) + ((trace-let-syntax) trace-let-syntax-macro) + ((trace-letrec-syntax) trace-letrec-syntax-macro) ((define-condition-type) define-condition-type-macro) ((include-into) include-into-macro) ((eol-style)