* makefile now constructs many initial libraries.
This commit is contained in:
Abdulaziz Ghuloum
parent
d75f2ef04d
commit
2ec3a6da7c
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
109
src/makefile.ss
109
src/makefile.ss
|
|
@ -80,6 +80,44 @@
|
||||||
(define ikarus-system-primitives
|
(define ikarus-system-primitives
|
||||||
'(print-greeting))
|
'(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)
|
(define (make-collection)
|
||||||
(let ([set '()])
|
(let ([set '()])
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
@ -87,6 +125,7 @@
|
||||||
[(x) (set! set (cons x set))])))
|
[(x) (set! set (cons x set))])))
|
||||||
|
|
||||||
(define (make-system-data subst env)
|
(define (make-system-data subst env)
|
||||||
|
(define who 'make-system-data)
|
||||||
(let ([export-subst (make-collection)]
|
(let ([export-subst (make-collection)]
|
||||||
[export-env (make-collection)]
|
[export-env (make-collection)]
|
||||||
[export-primlocs (make-collection)])
|
[export-primlocs (make-collection)])
|
||||||
|
|
@ -100,6 +139,8 @@
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(cond
|
(cond
|
||||||
|
[(assq x (export-subst))
|
||||||
|
(error who "ambiguous export of ~s" x)]
|
||||||
[(assq x subst) =>
|
[(assq x subst) =>
|
||||||
(lambda (p)
|
(lambda (p)
|
||||||
(let ([label (cdr p)])
|
(let ([label (cdr p)])
|
||||||
|
|
@ -119,31 +160,52 @@
|
||||||
ikarus-system-primitives)
|
ikarus-system-primitives)
|
||||||
(values (export-subst) (export-env) (export-primlocs))))
|
(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)
|
(define (build-system-library export-subst export-env primlocs)
|
||||||
(let-values ([(code empty-subst empty-env)
|
(define (build-library legend-entry)
|
||||||
(boot-library-expand
|
(let ([key (car legend-entry)] [name (cadr legend-entry)])
|
||||||
`(library (ikarus primlocs)
|
(let ([id (gensym)]
|
||||||
(export) ;;; must be empty
|
[name name]
|
||||||
(import (scheme))
|
[version '()]
|
||||||
(current-primitive-locations
|
[import-libs '()]
|
||||||
(lambda (x)
|
[visit-libs '()]
|
||||||
(cond
|
[invoke-libs '()]
|
||||||
[(assq x ',primlocs) => cdr]
|
[subst (get-export-subset key export-subst)]
|
||||||
[else #f])))
|
[env (if (equal? name '(ikarus system)) export-env '())])
|
||||||
(install-library
|
`(install-library
|
||||||
',(gensym "system") ;;; id
|
',id ',name ',version ',import-libs ',visit-libs ',invoke-libs
|
||||||
'(system) ;;; name
|
',subst ',env void void))))
|
||||||
'() ;;; version
|
(let ([code `(library (ikarus primlocs)
|
||||||
'() ;;; import libs
|
(export) ;;; must be empty
|
||||||
'() ;;; visit libs
|
(import (scheme))
|
||||||
'() ;;; invoke libs
|
(current-primitive-locations
|
||||||
',export-subst ;;; substitution
|
(lambda (x)
|
||||||
',export-env ;;; environment
|
(cond
|
||||||
void void ;;; visit/invoke codes
|
[(assq x ',primlocs) => cdr]
|
||||||
)))])
|
[else #f])))
|
||||||
(pretty-print code)
|
,@(map build-library library-legend))])
|
||||||
code))
|
(parameterize ([print-gensym #f])
|
||||||
|
(pretty-print code))
|
||||||
|
(let-values ([(code empty-subst empty-env)
|
||||||
|
(boot-library-expand code)])
|
||||||
|
code)))
|
||||||
|
|
||||||
(define (expand-all files)
|
(define (expand-all files)
|
||||||
(let ([code* '()]
|
(let ([code* '()]
|
||||||
|
|
@ -159,6 +221,7 @@
|
||||||
(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)
|
||||||
|
(printf "building system ...\n")
|
||||||
(let-values ([(export-subst export-env export-locs)
|
(let-values ([(export-subst export-env export-locs)
|
||||||
(make-system-data subst env)])
|
(make-system-data subst env)])
|
||||||
(let ([code (build-system-library export-subst export-env export-locs)])
|
(let ([code (build-system-library export-subst export-env export-locs)])
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue