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

* Made top-level set! more like r5rs's top-level set!.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-15 23:42:43 -04:00
parent 79916549cd
commit 411c05c74b
3 changed files with 37 additions and 21 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

@ -1817,6 +1817,8 @@
value
(chi-expr v r mr))]
;;; FIXME: handle macro!
[(global core-prim)
(stx-error e "cannot modify imported identifier in")]
[else (stx-error e)]))])))
(define chi-lambda-clause
(lambda (fmls body* r mr)
@ -2052,9 +2054,11 @@
mod** kwd* rib top?)
(values e* r mr lex* rhs* mod** kwd*))]))))])))
(define set-global-macro-binding!
(lambda (loc b) (error 'set-global-macro-binding! "not yet")))
(lambda (sym loc b)
(extend-library-subst! (interaction-library) sym loc)
(extend-library-env! (interaction-library) loc b)))
(define gen-global-macro-binding
(lambda (id) (error 'gen-global-macro-binding "not yet")))
(lambda (id ctxt) (gen-global-var-binding id ctxt)))
(define gen-global-var-binding
(lambda (id ctxt)
(let ([label (id->label id)])
@ -2068,7 +2072,14 @@
loc]
[else
(stx-error ctxt "cannot modify imported binding")])))]
[else (stx-error ctxt "cannot modify")])))))
[else (stx-error ctxt "cannot modify binding in")])))))
(define chi-top-set!
(lambda (e)
(syntax-match e ()
[(_ id rhs) (id? id)
(let ([loc (gen-global-var-binding id e)])
(let ([rhs (chi-expr rhs '() '())])
(values loc rhs)))])))
(define chi-top*
(lambda (e* init*)
(cond
@ -2082,12 +2093,15 @@
(let ([loc (gen-global-var-binding id e)])
(let ([rhs (chi-rhs rhs '() '())])
(chi-top* (cdr e*) (cons (cons loc rhs) init*)))))]
[(set!)
(let-values ([(loc rhs) (chi-top-set! e)])
(chi-top* (cdr e*) (cons (cons loc rhs) init*)))]
[(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)])
(let ([loc (gen-global-macro-binding id)])
(let ([loc (gen-global-macro-binding id e)])
(let ([expanded-rhs (expand-transformer rhs '())])
(let ([b (make-eval-transformer expanded-rhs)])
(set-global-macro-binding! loc b)
(set-global-macro-binding! (id->sym id) loc b)
(chi-top* (cdr e*) init*)))))]
[(begin)
(syntax-match e ()
@ -2560,7 +2574,9 @@
(lambda (x . args)
(unless (andmap string? args)
(error 'syntax-error "invalid argument ~s" args))
(error #f "~s ~a" (strip x '()) (apply string-append args))))
(if (null? args)
(error #f "invalid syntax ~s" (strip x '()))
(error #f "~s ~a" (strip x '()) (apply string-append args)))))
(define identifier? (lambda (x) (id? x)))
(define datum->syntax
(lambda (id datum)

30
src/todo-r6rs.ss
View File

@ -275,30 +275,30 @@
[fxarithmetic-shift C fx]
[fxarithmetic-shift-left C fx]
[fxarithmetic-shift-right C fx]
[fxbit-count D fx]
[fxbit-field D fx]
[fxbit-set? D fx]
[fxcopy-bit D fx]
[fxcopy-bit-field D fx]
[fxdiv D fx]
[fxdiv-and-mod D fx]
[fxdiv0 D fx]
[fxdiv0-and-mod0 D fx]
[fxbit-count S fx]
[fxbit-field S fx]
[fxbit-set? S fx]
[fxcopy-bit S fx]
[fxcopy-bit-field S fx]
[fxdiv S fx]
[fxdiv-and-mod S fx]
[fxdiv0 S fx]
[fxdiv0-and-mod0 S fx]
[fxeven? C fx]
[fxfirst-bit-set D fx]
[fxfirst-bit-set S fx]
[fxif C fx]
[fxior C fx]
[fxlength D fx]
[fxlength S fx]
[fxmax C fx]
[fxmin C fx]
[fxmod D fx]
[fxmod0 D fx]
[fxmod S fx]
[fxmod0 S fx]
[fxnegative? C fx]
[fxnot C fx]
[fxodd? C fx]
[fxpositive? C fx]
[fxreverse-bit-field D fx]
[fxrotate-bit-field D fx]
[fxreverse-bit-field S fx]
[fxrotate-bit-field S fx]
[fxxor C fx]
[fxzero? C fx]
;;;