* added a primitive-location parameter.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-02 02:16:56 -04:00
parent efded22ebc
commit 8383fd79d6
4 changed files with 48 additions and 23 deletions

Binary file not shown.

View File

@ -5313,6 +5313,5 @@
(error 'compile-time-core-eval "~s is not a procedure" f))
f)))
))

View File

@ -1,9 +1,14 @@
;;; Finally, we're ready to evaluate the files and enter the cafe.
(library (ikarus interaction)
(export foo)
(import (scheme))
(define foo 12)
(define foo 'i-am-an-exported-primitive-named-foo)
(define sc-expand
(lambda (x)
(if (and (pair? x) (equal? (car x) "noexpand"))

View File

@ -54,34 +54,55 @@
'()
(cons x (f))))))))
(define (expand-file filename codes env)
(with-input-from-file filename
(lambda ()
(let f ()
(let ([x (read)])
(cond
[(eof-object? x) (values codes env)]
[else
(let-values ([(code e)
(define-record library (code env))
(define (expand-file filename)
(map (lambda (x)
(let-values ([(code env)
(boot-library-expand x)])
(let-values ([(codes e*) (f)])
(values (cons code codes) (append e e*))))]))))))
(make-library code env)))
(read-file filename)))
(define (expand-files ls)
(define (make-primloc-library env)
`(library (ikarus primlocs)
(export)
(import (scheme))
(primitive-set! 'primitive-location
(make-parameter
(lambda (x)
(cond
[(null? ls) (values '() '())]
[else
(let-values ([(codes env) (expand-files (cdr ls))])
(expand-file (car ls) codes env))]))
[(assq x ',env) =>
(lambda (x)
(let ([type (caddr x)] [loc (cadddr x)])
(case type
[(global) (cons type loc)]
[else #f])))]
[else #f]))
(lambda (x)
(if (procedure? x) x
(error 'primitive-location
"~s is not a procedure" x)))))))
(define (expand-all ls)
(let-values ([(codes env) (expand-files ls)])
codes))
(define (insert x ls)
(cond ;;; insert before last library
[(null? (cdr ls))
(list x (library-code (car ls)))]
[else
(cons (library-code (car ls))
(insert x (cdr ls)))]))
(let ([libs (apply append (map expand-file ls))])
(let ([env (apply append (map library-env libs))])
(let-values ([(code _)
(boot-library-expand
(make-primloc-library env))])
(printf "ENV=~s\n" env)
(values (insert code libs) env)))))
(printf "expanding ...\n")
(let ([core* (expand-all scheme-library-files)])
(let-values ([(core* env) (expand-all scheme-library-files)])
(printf "compiling ...\n")
(let ([p (open-output-file "ikarus.boot" 'replace)])
(for-each