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 value
(chi-expr v r mr))] (chi-expr v r mr))]
;;; FIXME: handle macro! ;;; FIXME: handle macro!
[(global core-prim)
(stx-error e "cannot modify imported identifier in")]
[else (stx-error e)]))]))) [else (stx-error e)]))])))
(define chi-lambda-clause (define chi-lambda-clause
(lambda (fmls body* r mr) (lambda (fmls body* r mr)
@ -2052,9 +2054,11 @@
mod** kwd* rib top?) mod** kwd* rib top?)
(values e* r mr lex* rhs* mod** kwd*))]))))]))) (values e* r mr lex* rhs* mod** kwd*))]))))])))
(define set-global-macro-binding! (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 (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 (define gen-global-var-binding
(lambda (id ctxt) (lambda (id ctxt)
(let ([label (id->label id)]) (let ([label (id->label id)])
@ -2068,7 +2072,14 @@
loc] loc]
[else [else
(stx-error ctxt "cannot modify imported binding")])))] (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* (define chi-top*
(lambda (e* init*) (lambda (e* init*)
(cond (cond
@ -2082,12 +2093,15 @@
(let ([loc (gen-global-var-binding id e)]) (let ([loc (gen-global-var-binding id e)])
(let ([rhs (chi-rhs rhs '() '())]) (let ([rhs (chi-rhs rhs '() '())])
(chi-top* (cdr e*) (cons (cons loc rhs) init*)))))] (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) [(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)]) (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 ([expanded-rhs (expand-transformer rhs '())])
(let ([b (make-eval-transformer expanded-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*)))))] (chi-top* (cdr e*) init*)))))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
@ -2560,7 +2574,9 @@
(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 "~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 identifier? (lambda (x) (id? x)))
(define datum->syntax (define datum->syntax
(lambda (id datum) (lambda (id datum)

30
src/todo-r6rs.ss
View File

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