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

* added environment, environment?, and eval as specified by r6rs.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-11 21:06:31 -04:00
parent 008457c5f8
commit 29c43af1f4
3 changed files with 35 additions and 3 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.

35
src/ikarus.syntax.ss
View File

@ -6,8 +6,8 @@
;;; (apply (lambda ---) ls) is also common in this file. ;;; (apply (lambda ---) ls) is also common in this file.
(library (ikarus syntax) (library (ikarus syntax)
(export identifier? syntax-dispatch (export identifier? syntax-dispatch environment environment?
generate-temporaries free-identifier=? syntax-error eval generate-temporaries free-identifier=? syntax-error
eval-r6rs-top-level boot-library-expand eval-top-level) eval-r6rs-top-level boot-library-expand eval-top-level)
(import (import
(r6rs) (r6rs)
@ -16,7 +16,8 @@
(chez modules) (chez modules)
(ikarus symbols) (ikarus symbols)
(ikarus parameters) (ikarus parameters)
(only (ikarus) error printf ormap andmap list* format make-record-type void) (only (ikarus) error printf ormap andmap list* format
make-record-type void set-rtd-printer! type-descriptor)
(only (r6rs syntax-case) syntax-case syntax with-syntax) (only (r6rs syntax-case) syntax-case syntax with-syntax)
(prefix (r6rs syntax-case) sys:)) (prefix (r6rs syntax-case) sys:))
(define who 'expander) (define who 'expander)
@ -2129,6 +2130,29 @@
(values (rtc) (values (rtc)
(build-letrec* no-source (build-letrec* no-source
lex* rhs* invoke-body)))))))))))) lex* rhs* invoke-body))))))))))))
(define-record eval-environment (subst imp*))
(define environment
(lambda imp*
(let-values ([(subst imp*) (get-import-subst/libs imp*)])
(make-eval-environment subst imp*))))
(define environment?
(lambda (x) (eval-environment? x)))
(define eval
(lambda (x env)
(unless (eval-environment? env)
(error 'eval "~s is not an environment" env))
(let ([subst (eval-environment-subst env)])
(let ([rib (make-top-rib subst)])
(let ([x (stx x top-mark* (list rib))]
[rtc (make-collector)]
[vtc (make-collector)])
(let ([x
(parameterize ([inv-collector rtc]
[vis-collector vtc])
(chi-expr x '() '()))])
(seal-rib! rib)
(for-each invoke-library (rtc))
(eval-core x)))))))
(define (visit! macro*) (define (visit! macro*)
(for-each (lambda (x) (for-each (lambda (x)
(let ([loc (car x)] [proc (cadr x)]) (let ([loc (car x)] [proc (cadr x)])
@ -2246,6 +2270,11 @@
(for-each eval-binding (reverse (cdr init*))) (for-each eval-binding (reverse (cdr init*)))
(eval-binding (car init*))]))))) (eval-binding (car init*))])))))
;;; FIXME: export the rest of the syntax-case procedures ;;; FIXME: export the rest of the syntax-case procedures
(set-rtd-printer! (type-descriptor eval-environment)
(lambda (x p)
(unless (eval-environment? x)
(error 'record-type-printer "not an environment"))
(display (format "#<environment>") p)))
(current-library-expander (current-library-expander
(lambda (x) (lambda (x)
(library-expander x) (library-expander x)

3
src/makefile.ss
View File

@ -380,6 +380,9 @@
[load i] [load i]
[assembler-output i] [assembler-output i]
[new-cafe i] [new-cafe i]
[eval i]
[environment i]
[environment? i]
[time-it i] [time-it i]
[command-line-arguments i] [command-line-arguments i]
[record? i] [record? i]