* added current-library-collection and library-name to
ikarus.system.$bootstrap
This commit is contained in:
parent
6bdb50004a
commit
026f786bf9
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -1,5 +1,5 @@
|
||||||
|
|
||||||
(library (ikarus.code-objects)
|
(library (ikarus code-objects)
|
||||||
(export
|
(export
|
||||||
make-code code-reloc-vector code-freevars
|
make-code code-reloc-vector code-freevars
|
||||||
code-size code-ref code-set! set-code-reloc-vector!
|
code-size code-ref code-set! set-code-reloc-vector!
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
|
|
||||||
(library (ikarus.compiler)
|
(library (ikarus compiler)
|
||||||
(export compile-core-expr-to-port assembler-output
|
(export compile-core-expr-to-port assembler-output
|
||||||
current-primitive-locations eval-core)
|
current-primitive-locations eval-core)
|
||||||
(import
|
(import
|
||||||
|
@ -8,8 +8,8 @@
|
||||||
(except (ikarus)
|
(except (ikarus)
|
||||||
compile-core-expr-to-port assembler-output
|
compile-core-expr-to-port assembler-output
|
||||||
current-primitive-locations eval-core)
|
current-primitive-locations eval-core)
|
||||||
(ikarus.intel-assembler)
|
(ikarus intel-assembler)
|
||||||
(ikarus.fasl.write))
|
(ikarus fasl write))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -36,7 +36,7 @@
|
||||||
(library (ikarus fasl read)
|
(library (ikarus fasl read)
|
||||||
(export fasl-read)
|
(export fasl-read)
|
||||||
(import (ikarus)
|
(import (ikarus)
|
||||||
(ikarus.code-objects)
|
(ikarus code-objects)
|
||||||
(ikarus system $codes)
|
(ikarus system $codes)
|
||||||
(ikarus system $records))
|
(ikarus system $records))
|
||||||
|
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
|
|
||||||
|
|
||||||
(library (ikarus.intel-assembler)
|
(library (ikarus intel-assembler)
|
||||||
(export assemble-sources)
|
(export assemble-sources)
|
||||||
(import
|
(import
|
||||||
(ikarus)
|
(ikarus)
|
||||||
(ikarus.code-objects)
|
(ikarus code-objects)
|
||||||
(ikarus system $pairs))
|
(ikarus system $pairs))
|
||||||
|
|
||||||
(define fold
|
(define fold
|
||||||
|
|
|
@ -4,10 +4,11 @@
|
||||||
(library (ikarus library-manager)
|
(library (ikarus library-manager)
|
||||||
(export imported-label->binding library-subst
|
(export imported-label->binding library-subst
|
||||||
installed-libraries visit-library
|
installed-libraries visit-library
|
||||||
|
library-name
|
||||||
find-library-by-name install-library
|
find-library-by-name install-library
|
||||||
library-spec invoke-library
|
library-spec invoke-library
|
||||||
extend-library-subst! extend-library-env!
|
extend-library-subst! extend-library-env!
|
||||||
current-library-expander)
|
current-library-expander current-library-collection)
|
||||||
(import (except (ikarus) installed-libraries))
|
(import (except (ikarus) installed-libraries))
|
||||||
|
|
||||||
(define (make-collection)
|
(define (make-collection)
|
||||||
|
|
|
@ -131,7 +131,12 @@
|
||||||
(set-rib-label*! rib (cons label (rib-label* rib)))))]
|
(set-rib-label*! rib (cons label (rib-label* rib)))))]
|
||||||
[else (error 'extend-rib/check! "~s is not a rib" rib)]))
|
[else (error 'extend-rib/check! "~s is not a rib" rib)]))
|
||||||
(module (make-stx stx? stx-expr stx-mark* stx-subst*)
|
(module (make-stx stx? stx-expr stx-mark* stx-subst*)
|
||||||
(define-record stx (expr mark* subst*)))
|
(define-record stx (expr mark* subst*))
|
||||||
|
(set-rtd-printer! (type-descriptor stx)
|
||||||
|
(lambda (x p)
|
||||||
|
(display "#<syntax " p)
|
||||||
|
(display (stx->datum x) p)
|
||||||
|
(display ">" p))))
|
||||||
(define (seal-rib! rib)
|
(define (seal-rib! rib)
|
||||||
(let ([sym* (rib-sym* rib)])
|
(let ([sym* (rib-sym* rib)])
|
||||||
(unless (null? sym*)
|
(unless (null? sym*)
|
||||||
|
@ -433,8 +438,8 @@
|
||||||
(define-syntax stx-error
|
(define-syntax stx-error
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
[(_ stx) #'(error #f "invalid syntax ~s" (strip stx '()))]
|
[(_ stx) #'(error 'stx-error "invalid syntax ~s" (strip stx '()))]
|
||||||
[(_ stx msg) #'(error #f "~a: ~s" msg (strip stx '()))])))
|
[(_ stx msg) #'(error 'stx-error "~a: ~s" msg (strip stx '()))])))
|
||||||
(define sanitize-binding
|
(define sanitize-binding
|
||||||
(lambda (x src)
|
(lambda (x src)
|
||||||
(cond
|
(cond
|
||||||
|
|
|
@ -1,11 +1,12 @@
|
||||||
#!/usr/bin/env ikarus -b ikarus.boot --r6rs-script
|
#!/usr/bin/env ikarus -b ikarus.boot --r6rs-script
|
||||||
|
|
||||||
;(import
|
|
||||||
; ;(only (ikarus system $bootstrap) boot-library-expand)
|
;(import (except (ikarus) assembler-output)
|
||||||
; (ikarus.compiler)
|
; (ikarus compiler)
|
||||||
; (ikarus.syntax)
|
; (except (ikarus system $bootstrap)
|
||||||
; (except (ikarus)
|
; eval-core
|
||||||
; assembler-output))
|
; current-primitive-locations
|
||||||
|
; compile-core-expr-to-port))
|
||||||
|
|
||||||
(import (ikarus) (ikarus system $bootstrap))
|
(import (ikarus) (ikarus system $bootstrap))
|
||||||
|
|
||||||
|
@ -431,6 +432,8 @@
|
||||||
[current-primitive-locations $boot]
|
[current-primitive-locations $boot]
|
||||||
[boot-library-expand $boot]
|
[boot-library-expand $boot]
|
||||||
[eval-core $boot]
|
[eval-core $boot]
|
||||||
|
[current-library-collection $boot]
|
||||||
|
[library-name $boot]
|
||||||
|
|
||||||
[$car $pairs]
|
[$car $pairs]
|
||||||
[$cdr $pairs]
|
[$cdr $pairs]
|
||||||
|
@ -682,7 +685,7 @@
|
||||||
(import
|
(import
|
||||||
(only (ikarus library-manager)
|
(only (ikarus library-manager)
|
||||||
install-library)
|
install-library)
|
||||||
(only (ikarus.compiler)
|
(only (ikarus compiler)
|
||||||
current-primitive-locations)
|
current-primitive-locations)
|
||||||
(ikarus))
|
(ikarus))
|
||||||
(current-primitive-locations
|
(current-primitive-locations
|
||||||
|
@ -695,13 +698,58 @@
|
||||||
(boot-library-expand code)])
|
(boot-library-expand code)])
|
||||||
code)))
|
code)))
|
||||||
|
|
||||||
|
|
||||||
|
;;; (define (install-system-libraries export-subst export-env)
|
||||||
|
;;; (define (install legend-entry)
|
||||||
|
;;; (let ([key (car legend-entry)]
|
||||||
|
;;; [name (cadr legend-entry)]
|
||||||
|
;;; [visible? (caddr legend-entry)])
|
||||||
|
;;; (let ([id (gensym)]
|
||||||
|
;;; [name name]
|
||||||
|
;;; [version '()]
|
||||||
|
;;; [import-libs '()]
|
||||||
|
;;; [visit-libs '()]
|
||||||
|
;;; [invoke-libs '()])
|
||||||
|
;;; (let-values ([(subst env)
|
||||||
|
;;; (if (equal? name '(ikarus system $all))
|
||||||
|
;;; (values export-subst export-env)
|
||||||
|
;;; (values
|
||||||
|
;;; (get-export-subset key export-subst)
|
||||||
|
;;; '()))])
|
||||||
|
;;; (install-library
|
||||||
|
;;; id name version import-libs visit-libs invoke-libs
|
||||||
|
;;; subst env void void visible?)))))
|
||||||
|
;;; (for-each install library-legend))
|
||||||
|
|
||||||
|
; (let ([code `(library (ikarus primlocs)
|
||||||
|
; (export) ;;; must be empty
|
||||||
|
; (import
|
||||||
|
; (only (ikarus library-manager)
|
||||||
|
; install-library)
|
||||||
|
; (only (ikarus.compiler)
|
||||||
|
; current-primitive-locations)
|
||||||
|
; (ikarus))
|
||||||
|
; (current-primitive-locations
|
||||||
|
; (lambda (x)
|
||||||
|
; (cond
|
||||||
|
; [(assq x ',primlocs) => cdr]
|
||||||
|
; [else #f])))
|
||||||
|
; ,@(map build-library library-legend))])
|
||||||
|
; (let-values ([(code empty-subst empty-env)
|
||||||
|
; (boot-library-expand code)])
|
||||||
|
; code)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define (expand-all files)
|
(define (expand-all files)
|
||||||
(let ([code* '()]
|
(let ([code* '()]
|
||||||
[subst '()]
|
[subst '()]
|
||||||
[env '()])
|
[env '()])
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (file)
|
(lambda (file)
|
||||||
;(printf "expanding ~s\n" file)
|
(printf "expanding ~s\n" file)
|
||||||
(load file
|
(load file
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(let-values ([(code export-subst export-env)
|
(let-values ([(code export-subst export-env)
|
||||||
|
@ -719,6 +767,21 @@
|
||||||
|
|
||||||
(verify-map)
|
(verify-map)
|
||||||
|
|
||||||
|
;;; (let* ([names (append (map car ikarus-system-macros)
|
||||||
|
;;; (map car ikarus-procedures-map))]
|
||||||
|
;;; [labels (map (lambda (x) (gensym "boot")) names)]
|
||||||
|
;;; [bindings
|
||||||
|
;;; (append (map cadr ikarus-system-macros)
|
||||||
|
;;; (map (lambda (x)
|
||||||
|
;;; (cons 'core-prim (car x)))
|
||||||
|
;;; ikarus-procedures-map))]
|
||||||
|
;;; [subst (map cons names labels)]
|
||||||
|
;;; [env (map cons labels bindings)])
|
||||||
|
;;; (install-system-libraries subst env))
|
||||||
|
;;;
|
||||||
|
;;; (printf "installed base libraries ~s\n"
|
||||||
|
;;; (installed-libraries))
|
||||||
|
|
||||||
(time-it "the entire bootstrap process"
|
(time-it "the entire bootstrap process"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let-values ([(core* locs)
|
(let-values ([(core* locs)
|
||||||
|
|
Loading…
Reference in New Issue