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

23
src/ikarus.timer.ss
View File

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

1
src/makefile.ss
View File

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

8
src/todo-r6rs.ss
View File

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