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

more preparations for separate compilation

This commit is contained in:
Abdulaziz Ghuloum 2008-02-18 20:28:54 -05:00
parent fa08c543bb
commit c430a91bb8
7 changed files with 70 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

10
scheme/ikarus.load.ss
View File

@ -18,7 +18,7 @@
(export load load-r6rs-top-level)
(import
(except (ikarus) load)
(only (psyntax expander) eval-top-level eval-r6rs-top-level)
(only (psyntax expander) eval-top-level compile-r6rs-top-level)
(only (ikarus reader) read-initial))
(define load-handler
@ -45,7 +45,7 @@
(read-and-eval p eval-proc)))
(close-input-port p))]))
(define load-r6rs-top-level
(lambda (x)
(lambda (x how)
(define (read-file)
(let ([p (open-input-file x)])
(let ([x (read-script-annotated p)])
@ -60,5 +60,9 @@
'()]
[else (cons x (f))]))))))))
(let ([prog (read-file)])
(eval-r6rs-top-level prog))))
(let ([thunk (compile-r6rs-top-level prog)])
(case how
[(run) (thunk)]
[(compile) (error 'load-r6rs "not yet")]
[else (error 'load-r6rs-top-level "invali argument" how)])))))
)

14
scheme/ikarus.main.ss
View File

@ -90,13 +90,25 @@
(die 'ikarus "--r6rs-script requires a script name")]
[else
(values '() (car d) 'r6rs-script (cdr d))]))]
[(string=? (car args) "--compile-r6rs-script")
(let ([d (cdr args)])
(cond
[(null? d)
(die 'ikarus
"--compile-r6rs-script requires a script name")]
[else
(values '() (car d) 'compile-r6rs-script (cdr d))]))]
[else
(let-values ([(f* script script-type a*) (f (cdr args))])
(values (cons (car args) f*) script script-type a*))]))])
(cond
[(eq? script-type 'r6rs-script)
(command-line-arguments (cons script args))
(load-r6rs-top-level script)
(load-r6rs-top-level script 'run)
(exit 0)]
[(eq? script-type 'compile-r6rs-script)
(command-line-arguments (cons script args))
(load-r6rs-top-level script 'compile)
(exit 0)]
[(eq? script-type 'script) ; no greeting, no cafe
(command-line-arguments (cons script args))

2
scheme/last-revision
View File

@ -1 +1 @@
1392
1393

4
scheme/psyntax.compat.ss
View File

@ -19,11 +19,13 @@
eval-core symbol-value set-symbol-value!
file-options-spec make-struct-type read-annotated
annotation? annotation-expression annotation-source
annotation-stripped)
annotation-stripped load-precompiled-library)
(import
(only (ikarus.compiler) eval-core)
(ikarus))
(define (load-precompiled-library filename sk) #f)
(define-syntax define-record
(syntax-rules ()
[(_ name (field* ...) printer)

9
scheme/psyntax.expander.ss
View File

@ -24,7 +24,7 @@
bound-identifier=? datum->syntax syntax-error
syntax-violation
syntax->datum make-variable-transformer
eval-r6rs-top-level boot-library-expand eval-top-level
compile-r6rs-top-level boot-library-expand eval-top-level
null-environment scheme-report-environment ellipsis-map)
(import
(except (rnrs)
@ -3759,11 +3759,12 @@
(define syntax->datum
(lambda (x) (stx->datum x)))
(define eval-r6rs-top-level
(define compile-r6rs-top-level
(lambda (x*)
(let-values (((lib* invoke-code) (top-level-expander x*)))
(for-each invoke-library lib*)
(eval-core (expanded->core invoke-code)))))
(lambda ()
(for-each invoke-library lib*)
(eval-core (expanded->core invoke-code))))))
;;; The interaction-library is a parameter that is either #f
;;; (the default, for r6rs scripts) or set to an extensible library

51
scheme/psyntax.library-manager.ss
View File

@ -24,7 +24,8 @@
find-library-by-name install-library library-spec invoke-library
extend-library-subst! extend-library-env! current-library-expander
current-library-collection library-path library-extensions)
(import (rnrs) (psyntax compat) (rnrs r5rs))
(import (rnrs) (psyntax compat) (rnrs r5rs)
(only (ikarus) printf))
(define (make-collection)
(let ((set '()))
@ -155,10 +156,38 @@
f
(assertion-violation 'file-locator "not a procedure" f)))))
(define (library-precompiled? x) #f)
(define (load-precompiled-library x)
(error 'load-precompiled-library "not implemented"))
(define (try-load-from-file filename)
(load-precompiled-library filename
(case-lambda
[(id name ver imp* vis* inv* exp-subst exp-env
visit-proc invoke-proc visible?)
;;; make sure all dependencies are met
;;; if all is ok, install the library
;;; otherwise, return #f so that the
;;; library gets recompiled.
(let f ([deps (append imp* vis* inv*)])
(cond
[(null? deps)
(install-library id name ver imp* vis* inv*
exp-subst exp-env visit-proc invoke-proc
#f #f visible?)
#t]
[else
(let ([d (car deps)])
(let ([label (car d)] [dname (cadr d)])
(let ([l (find-library-by-name dname)])
(cond
[(and (library? l) (eq? label (library-id l)))
(f (cdr deps))]
[else
(printf
"WARNING: missing or inconsistent dependency \
on library ~s. \
Library ~s in file ~s will be recompiled.\n"
dname name filename)
#f]))))]))]
[others #f])))
(define library-loader
(make-parameter
@ -167,10 +196,9 @@
(cond
[(not file-name)
(assertion-violation #f "cannot file library" x)]
[(library-precompiled? file-name)
(load-precompiled-library file-name)]
[(try-load-from-file file-name)]
[else
((current-library-expander)
((current-library-expander)
(with-input-from-file file-name read-annotated))])))
(lambda (f)
(if (procedure? f)
@ -218,7 +246,8 @@
(let ((id (car spec)))
(or (find-library-by
(lambda (x) (eq? id (library-id x))))
(assertion-violation #f "cannot find library with required spec" spec))))
(assertion-violation #f
"cannot find library with required spec" spec))))
(define label->binding-table (make-eq-hashtable))
@ -278,7 +307,8 @@
(lambda () (assertion-violation 'invoke "circularity detected" lib)))
(for-each invoke-library (library-inv* lib))
(set-library-invoke-state! lib
(lambda () (assertion-violation 'invoke "first invoke did not return" lib)))
(lambda ()
(assertion-violation 'invoke "first invoke did not return" lib)))
(invoke)
(set-library-invoke-state! lib #t))))
@ -290,7 +320,8 @@
(lambda () (assertion-violation 'visit "circularity detected" lib)))
(for-each invoke-library (library-vis* lib))
(set-library-visit-state! lib
(lambda () (assertion-violation 'invoke "first visit did not return" lib)))
(lambda ()
(assertion-violation 'invoke "first visit did not return" lib)))
(visit)
(set-library-visit-state! lib #t))))