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

47
src/libsyntax.ss
View File

@ -2000,13 +2000,14 @@
(append
(map build-export lex*)
(chi-expr* init* r mr))))])
(values
name imp* (rtc)
(build-letrec no-source lex* rhs* body)
(map (find-export rib r) exp*))))))))))))
(let-values ([(export-subst export-env) (find-exports rib r exp*)])
(values
name imp* (rtc)
(build-letrec no-source lex* rhs* body)
export-subst export-env))))))))))))
(define run-library-expander
(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)])
;;; we need: name/ver/id,
;;; imports, visit, invoke name/ver/id
@ -2017,23 +2018,16 @@
[ver '()] ;;; FIXME
[imp* (map library-spec imp*)]
[vis* '()] ;;; FIXME
[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*)])
[inv* (map library-spec run*)])
(install-library id name ver
imp* vis* inv* exp-subst exp-env
imp* vis* inv* export-subst export-env
void ;;; FIXME
(lambda () (eval-core invoke-code)))))))
(define boot-library-expander
(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)])
(values invoke-code exp*))))
(values invoke-code export-subst export-env))))
(define build-export
(lambda (x)
;;; exports use the same gensym
@ -2051,7 +2045,26 @@
[(lexical)
;;; exports use the same gensym
(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! 'generate-temporaries
(lambda (ls)

124
src/makefile.ss
View File

@ -46,6 +46,37 @@
"library-manager.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)
(with-input-from-file file
(lambda ()
@ -55,45 +86,58 @@
'()
(cons x (f))))))))
(define-record library (code env))
(define-record library (code export-subst export-env))
(define must-export-primitives '())
(define (expand-file filename)
(map (lambda (x)
(let-values ([(code env)
(let-values ([(code export-subst export-env)
(boot-library-expand x)])
(make-library code env)))
(make-library code export-subst export-env)))
(read-file filename)))
(define (make-system-library defined-list)
(let ([name* (map car defined-list)]
[label* (map cadr defined-list)]
[type* (map caddr defined-list)]
[loc* (map cadddr defined-list)])
(let ([subst (map cons name* label*)]
[env (map (lambda (name label type loc)
(case type
[(global)
;;; install the new exports as prims
;;; of the new system
(cons label (cons 'core-prim name))]
[else (error 'make-system-library
"invalid export type ~s for ~s"
type name)]))
name* label* type* loc*)])
`(library (ikarus primlocs)
(export)
(import (scheme))
(install-library
',(gensym "system") ;;; id
'(system) ;;; name
'() ;;; version
'() ;;; import libs
'() ;;; visit libs
'() ;;; invoke libs
',subst ;;; substitution
',env ;;; environment
void void)))))
(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 must-export-primitives)
(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)
(export)
(import (scheme))
(install-library
',(gensym "system") ;;; id
'(system) ;;; name
'() ;;; version
'() ;;; import libs
'() ;;; visit libs
'() ;;; invoke libs
',export-subst ;;; substitution
',export-env ;;; environment
void void)))
(define (expand-all ls)
(define (insert x ls)
@ -104,16 +148,20 @@
(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 _)
(let* ([export-subst
(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
(make-system-library env))])
(printf "ENV=~s\n" env)
(values (insert code libs) env)))))
(make-system-library export-subst export-env))])
(printf "EXP:~s\n" (map car export-subst))
(values (insert code libs) #f)))))
(printf "expanding ...\n")
(let-values ([(core* env) (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