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

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

trace-define-syntax to handle variable transformers.

- added primops for fx comparison functions.
This commit is contained in:
Abdulaziz Ghuloum 2008-07-11 22:31:40 -07:00
parent 00970f12d2
commit eccca7f4ea
7 changed files with 124 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

1
scheme/ikarus.compiler.ss
View File

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

19
scheme/ikarus.trace.ss
View File

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

2
scheme/last-revision
View File

@ -1 +1 @@
1533
1534

7
scheme/makefile.ss
View File

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

60
scheme/pass-specify-rep-primops.ss
View File

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

45
scheme/psyntax.expander.ss
View File

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