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

* makefile now overrides the primlocs when compiling the files.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-04 07:16:32 -04:00
parent 0700cdc1cb
commit 09e1b8e615
2 changed files with 41 additions and 55 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.

96
src/makefile.ss
View File

@ -77,53 +77,23 @@
[and (macro . and)] [and (macro . and)]
[or (macro . or)])) [or (macro . or)]))
(define (read-file file) (define (make-system-data subst env)
(with-input-from-file file (define (add x s r l)
(lambda () (let ([name (car x)] [binding (cadr x)])
(let f () (case (car binding)
(let ([x (read)]) [(core-prim)
(if (eof-object? x) (error 'make-system-subst/env "cannot handle ~s" x)]
'() [else
(cons x (f)))))))) (let ([label (gensym)])
(values (cons (cons name label) s)
(define-record library (code export-subst export-env)) (cons (cons label binding) r)
l))])))
(define export-as-primitive '()) (let f ([ls ikarus-environment-map])
(define (expand-file filename)
(map (lambda (x)
(let-values ([(code export-subst export-env)
(boot-library-expand x)])
(make-library code export-subst export-env)))
(read-file filename)))
(define (inv-assq x ls)
(cond
[(null? ls) #f]
[(eq? x (cdar ls)) (car ls)]
[else (inv-assq x (cdr ls))]))
(define (sanitize-export-env subst r)
(define (add x r)
(let ([label (car x)] [b (cdr x)])
(let ([type (car b)] [val (cdr b)])
(case type
[(global)
(cond
[(inv-assq label subst) =>
(lambda (v)
(let ([name (car v)])
(cond
[(memq name export-as-primitive)
(cons (cons label (cons 'core-prim name)) r)]
[else
(cons (cons label (cons 'global val)) r)])))]
[else (error #f "cannot find binding for ~s" x)])]
[else (error #f "cannot handle export for ~s" x)]))))
(let f ([r r])
(cond (cond
[(null? r) '()] [(null? ls) (values '() '() '())]
[else (add (car r) (f (cdr r)))]))) [else
(let-values ([(subst env primlocs) (f (cdr ls))])
(add (car ls) subst env primlocs))])))
(define (build-system-library export-subst export-env primlocs) (define (build-system-library export-subst export-env primlocs)
(let-values ([(code empty-subst empty-env) (let-values ([(code empty-subst empty-env)
@ -150,6 +120,16 @@
(pretty-print code) (pretty-print code)
code)) code))
; (define (env->primlocs env)
; (let f ([ls env])
; (cond
; [(null? ls) '()]
; [else
; (let ([x (car ls)])
; (let ([label (car x)] [binding (cdr x)])
; (let ([type (car binding)] [value (cdr binding)])
; (case type
; [(global)
(define (expand-all files) (define (expand-all files)
(let ([code* '()] (let ([code* '()]
@ -165,21 +145,27 @@
(set! subst (append export-subst subst)) (set! subst (append export-subst subst))
(set! env (append export-env env)))))) (set! env (append export-env env))))))
files) files)
(let ([env (sanitize-export-env subst env)]) (let-values ([(export-subst export-env export-locs)
(let ([code (build-system-library subst env '())]) (make-system-data subst env)])
(let ([code (build-system-library export-subst export-env export-locs)])
(values (values
(reverse (list* (car code*) code (cdr code*))) (reverse (list* (car code*) code (cdr code*)))
subst env))))) export-locs)))))
(printf "expanding ...\n") (printf "expanding ...\n")
(let-values ([(core* subst env) (expand-all scheme-library-files)]) (let-values ([(core* locs) (expand-all scheme-library-files)])
(printf "compiling ...\n") (printf "compiling ...\n")
(let ([p (open-output-file "ikarus.boot" 'replace)]) (parameterize ([current-primitive-locations
(for-each (lambda (x)
(lambda (x) (compile-core-expr-to-port x p)) (cond
core*) [(assq x locs) => cdr]
(close-output-port p))) [else #f]))])
(let ([p (open-output-file "ikarus.boot" 'replace)])
(for-each
(lambda (x) (compile-core-expr-to-port x p))
core*)
(close-output-port p))))
(printf "Happy Happy Joy Joy\n")) (printf "Happy Happy Joy Joy\n"))