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

* working on cleaning up the makefile

This commit is contained in:
Abdulaziz Ghuloum 2007-05-03 03:58:43 -04:00
parent 2c25051855
commit b6734896e2
4 changed files with 119 additions and 59 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.

7
src/libintelasm.ss
View File

@ -38,7 +38,7 @@
(library (ikarus intel-assember) (library (ikarus intel-assember)
(export) (export assemble-sources)
(import (scheme)) (import (scheme))
(define fold (define fold
@ -953,8 +953,7 @@
;;; (make-code-executable! x) ;;; (make-code-executable! x)
;;; x))))) ;;; x)))))
(let () (define assemble-sources
(define list*->code*
(lambda (thunk?-label ls*) (lambda (thunk?-label ls*)
(let ([closure-size* (map car ls*)] (let ([closure-size* (map car ls*)]
[ls* (map cdr ls*)]) [ls* (map cdr ls*)])
@ -979,7 +978,7 @@
; (lambda (ls) ; (lambda (ls)
; (car (list*->code* (list ls))))) ; (car (list*->code* (list ls)))))
(primitive-set! 'list*->code* list*->code*)) (primitive-set! 'list*->code* assemble-sources)
) )

41
src/libsyntax.ss
View File

@ -2000,13 +2000,14 @@
(append (append
(map build-export lex*) (map build-export lex*)
(chi-expr* init* r mr))))]) (chi-expr* init* r mr))))])
(let-values ([(export-subst export-env) (find-exports rib r exp*)])
(values (values
name imp* (rtc) name imp* (rtc)
(build-letrec no-source lex* rhs* body) (build-letrec no-source lex* rhs* body)
(map (find-export rib r) exp*)))))))))))) export-subst export-env))))))))))))
(define run-library-expander (define run-library-expander
(lambda (x) (lambda (x)
(let-values ([(name imp* run* invoke-code exp*) (let-values ([(name imp* run* invoke-code export-subst export-env)
(core-library-expander x)]) (core-library-expander x)])
;;; we need: name/ver/id, ;;; we need: name/ver/id,
;;; imports, visit, invoke name/ver/id ;;; imports, visit, invoke name/ver/id
@ -2017,23 +2018,16 @@
[ver '()] ;;; FIXME [ver '()] ;;; FIXME
[imp* (map library-spec imp*)] [imp* (map library-spec imp*)]
[vis* '()] ;;; FIXME [vis* '()] ;;; FIXME
[inv* (map library-spec run*)] [inv* (map library-spec run*)])
[exp-subst
(map (lambda (x) (cons (car x) (cadr x))) exp*)]
[exp-env
(map (lambda (x)
(let ([label (cadr x)] [type (caddr x)] [val (cadddr x)])
(cons label (cons type val))))
exp*)])
(install-library id name ver (install-library id name ver
imp* vis* inv* exp-subst exp-env imp* vis* inv* export-subst export-env
void ;;; FIXME void ;;; FIXME
(lambda () (eval-core invoke-code))))))) (lambda () (eval-core invoke-code)))))))
(define boot-library-expander (define boot-library-expander
(lambda (x) (lambda (x)
(let-values ([(name imp* run* invoke-code exp*) (let-values ([(name imp* run* invoke-code export-subst export-env)
(core-library-expander x)]) (core-library-expander x)])
(values invoke-code exp*)))) (values invoke-code export-subst export-env))))
(define build-export (define build-export
(lambda (x) (lambda (x)
;;; exports use the same gensym ;;; exports use the same gensym
@ -2051,7 +2045,26 @@
[(lexical) [(lexical)
;;; exports use the same gensym ;;; exports use the same gensym
(list sym label 'global (binding-value b))] (list sym label 'global (binding-value b))]
[else (error 'chi-library "cannot export ~s" sym)]))))) [else (error #f "cannot export ~s of type ~s" sym type)])))))
(define (find-exports rib r sym*)
;;; FIXME: check unique exports
(let f ([sym* sym*] [subst '()] [env '()])
(cond
[(null? sym*) (values subst env)]
[else
(let* ([sym (car sym*)]
[id (stx sym top-mark* (list rib))]
[label (id->label id)]
[b (label->binding label r)]
[type (binding-type b)])
(unless label
(stx-error id "cannot export unbound identifier"))
(case type
[(lexical)
(f (cdr sym*)
(cons (cons sym label) subst)
(cons (cons label (cons 'global (binding-value b))) env))]
[else (error #f "cannot export ~s of type ~s" sym type)]))])))
(primitive-set! 'identifier? id?) (primitive-set! 'identifier? id?)
(primitive-set! 'generate-temporaries (primitive-set! 'generate-temporaries
(lambda (ls) (lambda (ls)

100
src/makefile.ss
View File

@ -46,6 +46,37 @@
"library-manager.ss" "library-manager.ss"
"libtoplevel.ss")) "libtoplevel.ss"))
(define ikarus-environment-map
'([define (define)]
[define-syntax (define-syntax)]
[module (module)]
[begin (begin)]
[set! (set!)]
[foreign-call (core-macro . foreign-call)]
[quote (core-macro . quote)]
[syntax-case (core-macro . syntax-case)]
[syntax (core-macro . syntax)]
[lambda (core-macro . lambda)]
[case-lambda (core-macro . case-lambda)]
[type-descriptor (core-macro . type-descriptor)]
[letrec (core-macro . letrec)]
[if (core-macro . if)]
[when (core-macro . when)]
[unless (core-macro . unless)]
[parameterize (core-macro . parameterize)]
[case (core-macro . case)]
[let-values (core-macro . let-values)]
[define-record (macro . define-record)]
[include (macro . include)]
[syntax-rules (macro . syntax-rules)]
[quasiquote (macro . quasiquote)]
[with-syntax (macro . with-syntax)]
[let (macro . let)]
[let* (macro . let*)]
[cond (macro . cond)]
[and (macro . and)]
[or (macro . or)]))
(define (read-file file) (define (read-file file)
(with-input-from-file file (with-input-from-file file
(lambda () (lambda ()
@ -55,32 +86,45 @@
'() '()
(cons x (f)))))))) (cons x (f))))))))
(define-record library (code env)) (define-record library (code export-subst export-env))
(define must-export-primitives '())
(define (expand-file filename) (define (expand-file filename)
(map (lambda (x) (map (lambda (x)
(let-values ([(code env) (let-values ([(code export-subst export-env)
(boot-library-expand x)]) (boot-library-expand x)])
(make-library code env))) (make-library code export-subst export-env)))
(read-file filename))) (read-file filename)))
(define (make-system-library defined-list) (define (inv-assq x ls)
(let ([name* (map car defined-list)] (cond
[label* (map cadr defined-list)] [(null? ls) #f]
[type* (map caddr defined-list)] [(eq? x (cdar ls)) (car ls)]
[loc* (map cadddr defined-list)]) [else (inv-assq x (cdr ls))]))
(let ([subst (map cons name* label*)]
[env (map (lambda (name label type loc) (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 (case type
[(global) [(global)
;;; install the new exports as prims (cond
;;; of the new system [(inv-assq label subst) =>
(cons label (cons 'core-prim name))] (lambda (v)
[else (error 'make-system-library (let ([name (car v)])
"invalid export type ~s for ~s" (cond
type name)])) [(memq name must-export-primitives)
name* label* type* loc*)]) (cons (cons label (cons 'core-prim name)) r)]
[else r])))]
[else (error #f "cannot find binding for ~s" x)])]
[else (error #f "cannot handle export for ~s" x)]))))
(let f ([r r])
(cond
[(null? r) '()]
[else (add (car r) (f (cdr r)))])))
(define (make-system-library export-subst export-env)
`(library (ikarus primlocs) `(library (ikarus primlocs)
(export) (export)
(import (scheme)) (import (scheme))
@ -91,9 +135,9 @@
'() ;;; import libs '() ;;; import libs
'() ;;; visit libs '() ;;; visit libs
'() ;;; invoke libs '() ;;; invoke libs
',subst ;;; substitution ',export-subst ;;; substitution
',env ;;; environment ',export-env ;;; environment
void void))))) void void)))
(define (expand-all ls) (define (expand-all ls)
(define (insert x ls) (define (insert x ls)
@ -104,16 +148,20 @@
(cons (library-code (car ls)) (cons (library-code (car ls))
(insert x (cdr ls)))])) (insert x (cdr ls)))]))
(let ([libs (apply append (map expand-file ls))]) (let ([libs (apply append (map expand-file ls))])
(let ([env (apply append (map library-env libs))]) (let* ([export-subst
(let-values ([(code _) (apply append (map library-export-subst libs))]
[export-env
(sanitize-export-env export-subst
(apply append (map library-export-env libs)))])
(let-values ([(code _subst _env) ; both must be empty
(boot-library-expand (boot-library-expand
(make-system-library env))]) (make-system-library export-subst export-env))])
(printf "ENV=~s\n" env) (printf "EXP:~s\n" (map car export-subst))
(values (insert code libs) env))))) (values (insert code libs) #f)))))
(printf "expanding ...\n") (printf "expanding ...\n")
(let-values ([(core* env) (expand-all scheme-library-files)]) (let-values ([(core* ??env) (expand-all scheme-library-files)])
(printf "compiling ...\n") (printf "compiling ...\n")
(let ([p (open-output-file "ikarus.boot" 'replace)]) (let ([p (open-output-file "ikarus.boot" 'replace)])
(for-each (for-each