- Added trace-let-syntax, trace-letrec-syntax, as well as fixed

trace-define-syntax to handle variable transformers.

- added primops for fx comparison functions.

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*))]

scheme/ikarus.trace.ss

@@ -15,8 +15,8 @@
 
 
 (library (ikarus trace)
-  (export make-traced-procedure) 
+  (export make-traced-procedure make-traced-macro) 
-  (import (except (ikarus) make-traced-procedure))
+  (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

scheme/last-revision

@@ -1 +1 @@
-1533
+1534

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<?                                   i r uc se]

scheme/pass-specify-rep-primops.ss

@@ -1359,6 +1359,66 @@
   [(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 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 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)

scheme/psyntax.expander.ss

@@ -23,7 +23,10 @@
           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
@@ -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
+             (bless 
-                       (let ((v ,expr))
+               `(define-syntax ,who
-                         (if (procedure? v)
+                  (make-traced-macro ',who ,expr)))
-                             (make-traced-procedure ',who v syntax->datum)
-                             (assertion-violation 'trace-define-syntax
-                                "not a procedure" v)))))
              (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)