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

* added current-library-collection and library-name to 

ikarus.system.$bootstrap
This commit is contained in:
Abdulaziz Ghuloum 2007-05-15 10:18:58 -04:00
parent 6bdb50004a
commit 026f786bf9
8 changed files with 88 additions and 19 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.

2
src/ikarus.code-objects.ss
View File

@ -1,5 +1,5 @@
(library (ikarus.code-objects)
(library (ikarus code-objects)
(export
make-code code-reloc-vector code-freevars
code-size code-ref code-set! set-code-reloc-vector!

6
src/ikarus.compiler.ss
View File

@ -1,5 +1,5 @@
(library (ikarus.compiler)
(library (ikarus compiler)
(export compile-core-expr-to-port assembler-output
current-primitive-locations eval-core)
(import
@ -8,8 +8,8 @@
(except (ikarus)
compile-core-expr-to-port assembler-output
current-primitive-locations eval-core)
(ikarus.intel-assembler)
(ikarus.fasl.write))
(ikarus intel-assembler)
(ikarus fasl write))

2
src/ikarus.fasl.ss
View File

@ -36,7 +36,7 @@
(library (ikarus fasl read)
(export fasl-read)
(import (ikarus)
(ikarus.code-objects)
(ikarus code-objects)
(ikarus system $codes)
(ikarus system $records))

4
src/ikarus.intel-assembler.ss
View File

@ -1,10 +1,10 @@
(library (ikarus.intel-assembler)
(library (ikarus intel-assembler)
(export assemble-sources)
(import
(ikarus)
(ikarus.code-objects)
(ikarus code-objects)
(ikarus system $pairs))
(define fold

3
src/ikarus.library-manager.ss
View File

@ -4,10 +4,11 @@
(library (ikarus library-manager)
(export imported-label->binding library-subst
installed-libraries visit-library
library-name
find-library-by-name install-library
library-spec invoke-library
extend-library-subst! extend-library-env!
current-library-expander)
current-library-expander current-library-collection)
(import (except (ikarus) installed-libraries))
(define (make-collection)

11
src/ikarus.syntax.ss
View File

@ -131,7 +131,12 @@
(set-rib-label*! rib (cons label (rib-label* rib)))))]
[else (error 'extend-rib/check! "~s is not a rib" rib)]))
(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)
(let ([sym* (rib-sym* rib)])
(unless (null? sym*)
@ -433,8 +438,8 @@
(define-syntax stx-error
(lambda (x)
(syntax-case x ()
[(_ stx) #'(error #f "invalid syntax ~s" (strip stx '()))]
[(_ stx msg) #'(error #f "~a: ~s" msg (strip stx '()))])))
[(_ stx) #'(error 'stx-error "invalid syntax ~s" (strip stx '()))]
[(_ stx msg) #'(error 'stx-error "~a: ~s" msg (strip stx '()))])))
(define sanitize-binding
(lambda (x src)
(cond

79
src/makefile.ss
View File

@ -1,11 +1,12 @@
#!/usr/bin/env ikarus -b ikarus.boot --r6rs-script
;(import
; ;(only (ikarus system $bootstrap) boot-library-expand)
; (ikarus.compiler)
; (ikarus.syntax)
; (except (ikarus)
; assembler-output))
;(import (except (ikarus) assembler-output)
; (ikarus compiler)
; (except (ikarus system $bootstrap)
; eval-core
; current-primitive-locations
; compile-core-expr-to-port))
(import (ikarus) (ikarus system $bootstrap))
@ -431,6 +432,8 @@
[current-primitive-locations $boot]
[boot-library-expand $boot]
[eval-core $boot]
[current-library-collection $boot]
[library-name $boot]
[$car $pairs]
[$cdr $pairs]
@ -682,7 +685,7 @@
(import
(only (ikarus library-manager)
install-library)
(only (ikarus.compiler)
(only (ikarus compiler)
current-primitive-locations)
(ikarus))
(current-primitive-locations
@ -695,13 +698,58 @@
(boot-library-expand 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)
(let ([code* '()]
[subst '()]
[env '()])
(for-each
(lambda (file)
;(printf "expanding ~s\n" file)
(printf "expanding ~s\n" file)
(load file
(lambda (x)
(let-values ([(code export-subst export-env)
@ -719,6 +767,21 @@
(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"
(lambda ()
(let-values ([(core* locs)