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

* Added make-variable-transformer procedure.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-02 02:03:29 -04:00
parent 7a3a984653
commit d515520bd7
5 changed files with 34 additions and 26 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.

28
src/ikarus.syntax.ss
View File

@ -9,7 +9,7 @@
(export identifier? syntax-dispatch environment environment?
eval generate-temporaries free-identifier=?
bound-identifier=? syntax-error datum->syntax
syntax->datum
syntax->datum make-variable-transformer
eval-r6rs-top-level boot-library-expand eval-top-level)
(import
(r6rs)
@ -136,7 +136,7 @@
(set-rtd-printer! (type-descriptor stx)
(lambda (x p)
(display "#<syntax " p)
(display (stx->datum x) p)
(write (stx->datum x) p)
(display ">" p))))
(define (seal-rib! rib)
(let ([sym* (rib-sym* rib)])
@ -442,7 +442,7 @@
(lambda (x)
(syntax-case x ()
[(_ stx) #'(error #f "invalid syntax ~s" (strip stx '()))]
[(_ stx msg) #'(error #f "~a: ~s" msg (strip stx '()))])))
[(_ stx msg) #'(error #f "~a ~s" msg (strip stx '()))])))
(define sanitize-binding
(lambda (x src)
(cond
@ -451,6 +451,12 @@
(list* 'local-macro! (cdr x) src)]
[(and (pair? x) (eq? (car x) '$rtd)) x]
[else (error 'expand "invalid transformer ~s" x)])))
(define make-variable-transformer
(lambda (x)
(if (procedure? x)
(cons 'macro! x)
(error 'make-variable-transformer
"~s is not a procedure" x))))
(define make-eval-transformer
(lambda (x)
(sanitize-binding (eval-core x) x)))
@ -635,7 +641,7 @@
(syntax-match e ()
[(_ ([lhs* rhs*] ...) b b* ...)
(if (not (valid-bound-ids? lhs*))
(stx-error e "duplicate identifiers")
(stx-error e "invalid identifiers")
(let ([lex* (map gen-lexical lhs*)]
[lab* (map gen-label lhs*)])
(let ([rib (make-full-rib lhs* lab*)]
@ -779,7 +785,7 @@
[(_ ([lhs* rhs*] ...) b b* ...)
(if (valid-bound-ids? lhs*)
(bless `((lambda ,lhs* ,b . ,b*) . ,rhs*))
(stx-error stx "duplicate bindings"))]
(stx-error stx "invalid bindings"))]
[(_ f ([lhs* rhs*] ...) b b* ...) (id? f)
(if (valid-bound-ids? lhs*)
(bless `(letrec ([,f (lambda ,lhs* ,b . ,b*)])
@ -823,7 +829,7 @@
,@command*
(loop ,@step*))))])
(loop ,@init*)))
(stx-error stx "duplicate bindings"))])])))
(stx-error stx "invalid bindings"))])])))
(define let*-macro
(lambda (stx)
(syntax-match stx ()
@ -1770,7 +1776,7 @@
(syntax-match e ()
[(_ ([xlhs* xrhs*] ...) xbody xbody* ...)
(unless (valid-bound-ids? xlhs*)
(stx-error e "duplicate identifiers"))
(stx-error e "invalid identifiers"))
(let* ([xlab* (map gen-label xlhs*)]
[xrib (make-full-rib xlhs* xlab*)]
[xb* (map (lambda (x)
@ -1974,7 +1980,7 @@
(syntax-match e ()
[(_ ([xlhs* xrhs*] ...) xbody* ...)
(unless (valid-bound-ids? xlhs*)
(stx-error e "duplicate identifiers"))
(stx-error e "invalid identifiers"))
(let* ([xlab* (map gen-label xlhs*)]
[xrib (make-full-rib xlhs* xlab*)]
[xb* (map (lambda (x)
@ -2107,7 +2113,7 @@
[(null? exp*)
(let ([id* (map (lambda (x) (stx x top-mark* '())) ext*)])
(unless (valid-bound-ids? id*)
(error #f "duplicate exports of ~s" (find-dups id*))))
(error #f "invalid exports of ~s" (find-dups id*))))
(values int* ext*)]
[else
(syntax-match (car exp*) ()
@ -2502,9 +2508,7 @@
(lambda (x . args)
(unless (andmap string? args)
(error 'syntax-error "invalid argument ~s" args))
(error #f "~a: ~s"
(apply string-append args)
(strip x '()))))
(error #f "~s ~a" (strip x '()) (apply string-append args))))
(define identifier? (lambda (x) (id? x)))
(define datum->syntax
(lambda (id datum)

23
src/ikarus.timer.ss
View File

@ -16,6 +16,8 @@
(define (mk-stats)
(make-stats #f #f #f #f #f #f #f #f #f #f #f #f #f))
(define verbose-timer (make-parameter #f))
(define (set-stats! t)
(foreign-call "ikrt_stats_now" t))
@ -48,16 +50,17 @@
(stats-real-usecs t1) (stats-real-usecs t0))
(msecs (stats-gc-real-secs t1) (stats-gc-real-secs t0)
(stats-gc-real-usecs t1) (stats-gc-real-usecs t0)))
(print-time "user"
(msecs (stats-user-secs t1) (stats-user-secs t0)
(stats-user-usecs t1) (stats-user-usecs t0))
(msecs (stats-gc-user-secs t1) (stats-gc-user-secs t0)
(stats-gc-user-usecs t1) (stats-gc-user-usecs t0)))
(print-time "sys"
(msecs (stats-sys-secs t1) (stats-sys-secs t0)
(stats-sys-usecs t1) (stats-sys-usecs t0))
(msecs (stats-gc-sys-secs t1) (stats-gc-sys-secs t0)
(stats-gc-sys-usecs t1) (stats-gc-sys-usecs t0)))
(when (verbose-timer)
(print-time "user"
(msecs (stats-user-secs t1) (stats-user-secs t0)
(stats-user-usecs t1) (stats-user-usecs t0))
(msecs (stats-gc-user-secs t1) (stats-gc-user-secs t0)
(stats-gc-user-usecs t1) (stats-gc-user-usecs t0)))
(print-time "sys"
(msecs (stats-sys-secs t1) (stats-sys-secs t0)
(stats-sys-usecs t1) (stats-sys-usecs t0))
(msecs (stats-gc-sys-secs t1) (stats-gc-sys-secs t0)
(stats-gc-sys-usecs t1) (stats-gc-sys-usecs t0))))
(printf " ~a bytes allocated\n" bytes))
(define (print-stats-old message bytes t1 t0)

1
src/makefile.ss
View File

@ -609,6 +609,7 @@
[bound-identifier=? i syncase]
[syntax->datum i syncase]
[datum->syntax i syncase]
[make-variable-transformer i syncase]
[code? i]
[immediate? i]
[pointer-value i]

8
src/todo-r6rs.ss
View File

@ -728,14 +728,14 @@
[syntax C sc]
[syntax->datum C sc]
[syntax-case C sc]
[unsyntax S sc]
[unsyntax-splicing S sc]
[quasisyntax S sc]
[unsyntax C sc]
[unsyntax-splicing C sc]
[quasisyntax C sc]
[with-syntax C sc]
[free-identifier=? C sc]
[generate-temporaries C sc]
[identifier? C sc]
[make-variable-transformer S sc]
[make-variable-transformer C sc]
;;;
[char-alphabetic? S uc se]
[char-ci<=? C uc se]