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

* makefile now constructs many initial libraries.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-04 09:13:14 -04:00
parent d75f2ef04d
commit 2ec3a6da7c
2 changed files with 86 additions and 23 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.

109
src/makefile.ss
View File

@ -80,6 +80,44 @@
(define ikarus-system-primitives
'(print-greeting))
(define library-legend
'([s (ikarus system)]
[i (ikarus)]
[r (r6rs)]))
(define ikarus-library-map
'([define s i r]
[define-syntax s i r]
[module s i ]
[begin s i r]
[set! s i r]
[foreign-call s i r]
[quote s i r]
[syntax-case s i r]
[syntax s i r]
[lambda s i r]
[case-lambda s i r]
[type-descriptor s i ]
[letrec s i r]
[if s i r]
[when s i r]
[unless s i r]
[parameterize s i ]
[case s i r]
[let-values s i r]
[define-record s i r]
[include s i r]
[syntax-rules s i r]
[quasiquote s i r]
[with-syntax s i r]
[let s i r]
[let* s i r]
[cond s i r]
[and s i r]
[or s i r]
[print-greeting s ]
))
(define (make-collection)
(let ([set '()])
(case-lambda
@ -87,6 +125,7 @@
[(x) (set! set (cons x set))])))
(define (make-system-data subst env)
(define who 'make-system-data)
(let ([export-subst (make-collection)]
[export-env (make-collection)]
[export-primlocs (make-collection)])
@ -100,6 +139,8 @@
(for-each
(lambda (x)
(cond
[(assq x (export-subst))
(error who "ambiguous export of ~s" x)]
[(assq x subst) =>
(lambda (p)
(let ([label (cdr p)])
@ -119,31 +160,52 @@
ikarus-system-primitives)
(values (export-subst) (export-env) (export-primlocs))))
(define (get-export-subset key subst)
(let f ([ls subst])
(cond
[(null? ls) '()]
[else
(let ([x (car ls)])
(let ([name (car x)])
(cond
[(assq name ikarus-library-map) =>
(lambda (q)
(cond
[(memq key (cdr q))
(cons x (f (cdr ls)))]
[else (f (cdr ls))]))]
[else
;;; not going to any library?
(f (cdr ls))])))])))
(define (build-system-library export-subst export-env primlocs)
(let-values ([(code empty-subst empty-env)
(boot-library-expand
`(library (ikarus primlocs)
(export) ;;; must be empty
(import (scheme))
(current-primitive-locations
(lambda (x)
(cond
[(assq x ',primlocs) => cdr]
[else #f])))
(install-library
',(gensym "system") ;;; id
'(system) ;;; name
'() ;;; version
'() ;;; import libs
'() ;;; visit libs
'() ;;; invoke libs
',export-subst ;;; substitution
',export-env ;;; environment
void void ;;; visit/invoke codes
)))])
(pretty-print code)
code))
(define (build-library legend-entry)
(let ([key (car legend-entry)] [name (cadr legend-entry)])
(let ([id (gensym)]
[name name]
[version '()]
[import-libs '()]
[visit-libs '()]
[invoke-libs '()]
[subst (get-export-subset key export-subst)]
[env (if (equal? name '(ikarus system)) export-env '())])
`(install-library
',id ',name ',version ',import-libs ',visit-libs ',invoke-libs
',subst ',env void void))))
(let ([code `(library (ikarus primlocs)
(export) ;;; must be empty
(import (scheme))
(current-primitive-locations
(lambda (x)
(cond
[(assq x ',primlocs) => cdr]
[else #f])))
,@(map build-library library-legend))])
(parameterize ([print-gensym #f])
(pretty-print code))
(let-values ([(code empty-subst empty-env)
(boot-library-expand code)])
code)))
(define (expand-all files)
(let ([code* '()]
@ -159,6 +221,7 @@
(set! subst (append export-subst subst))
(set! env (append export-env env))))))
files)
(printf "building system ...\n")
(let-values ([(export-subst export-env export-locs)
(make-system-data subst env)])
(let ([code (build-system-library export-subst export-env export-locs)])