- synching scheme/psyntax.*.ss from the psyntax distribution.
This commit is contained in:
Abdulaziz Ghuloum
parent
442f6e9049
commit
afa61cc1a7
|
|
@ -1 +1 @@
|
|||
1624
|
||||
1625
|
||||
|
|
|
|||
|
|
@ -141,8 +141,18 @@
|
|||
vars val-exps)
|
||||
(list body-exp)))))))))
|
||||
(define build-library-letrec*
|
||||
(lambda (ae vars locs val-exps body-exp)
|
||||
`(library-letrec* ,(map list vars locs val-exps) ,body-exp)))
|
||||
(lambda (ae top? vars locs val-exps body-exp)
|
||||
(if-wants-library-letrec*
|
||||
`(library-letrec* ,(map list vars locs val-exps) ,body-exp)
|
||||
(build-letrec* ae vars val-exps
|
||||
(if top?
|
||||
body-exp
|
||||
(build-sequence ae
|
||||
(cons body-exp
|
||||
(map (lambda (var loc)
|
||||
(build-global-assignment ae loc var))
|
||||
vars locs))))))))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -20,12 +20,35 @@
|
|||
make-struct-type read-annotated
|
||||
annotation? annotation-expression annotation-source
|
||||
annotation-stripped
|
||||
read-library-source-file)
|
||||
read-library-source-file
|
||||
library-version-mismatch-warning
|
||||
file-locator-resolution-error)
|
||||
(import
|
||||
(only (ikarus.compiler) eval-core)
|
||||
(only (ikarus.reader.annotated) read-library-source-file)
|
||||
(ikarus))
|
||||
|
||||
(define (library-version-mismatch-warning name depname filename)
|
||||
(fprintf (current-error-port)
|
||||
"WARNING: library ~s has an inconsistent dependency \
|
||||
on library ~s; file ~s will be recompiled from \
|
||||
source.\n"
|
||||
name depname filename))
|
||||
|
||||
(define (file-locator-resolution-error libname failed-list)
|
||||
(define-condition-type &library-resolution &condition
|
||||
make-library-resolution-condition
|
||||
library-resolution-condition?
|
||||
(library condition-library)
|
||||
(files condition-files))
|
||||
(raise
|
||||
(condition
|
||||
(make-error)
|
||||
(make-who-condition 'expander)
|
||||
(make-message-condition
|
||||
"cannot locate library in library-path")
|
||||
(make-library-resolution-condition
|
||||
libname failed-list))))
|
||||
|
||||
(define-syntax define-record
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -21,8 +21,13 @@
|
|||
(library (psyntax config)
|
||||
(export if-wants-define-record if-wants-define-struct
|
||||
if-wants-case-lambda
|
||||
if-wants-letrec* if-wants-global-defines)
|
||||
if-wants-letrec* if-wants-global-defines
|
||||
if-wants-library-letrec*
|
||||
base-of-interaction-library)
|
||||
(import (rnrs))
|
||||
|
||||
(define (base-of-interaction-library) '(ikarus))
|
||||
|
||||
(define-syntax define-option
|
||||
(syntax-rules ()
|
||||
((_ name #t)
|
||||
|
|
@ -34,6 +39,7 @@
|
|||
(syntax-rules ()
|
||||
((_ sk fk) fk))))))
|
||||
|
||||
|
||||
(define-option if-wants-define-record #t)
|
||||
(define-option if-wants-define-struct #t)
|
||||
;;; define-record is an ikarus-specific extension.
|
||||
|
|
@ -61,6 +67,9 @@
|
|||
;;; If the implementation has built-in support for
|
||||
;;; efficient letrec* (ikarus, chez), then this option
|
||||
;;; should be enabled. Disabling the option expands
|
||||
;;; (letrec* ([lhs* rhs*] ...) body) into
|
||||
;;; (let ([lhs* #f] ...) (set! lhs* rhs*) ... body)
|
||||
;;; (letrec* ((lhs* rhs*) ...) body) into
|
||||
;;; (let ((lhs* #f) ...) (set! lhs* rhs*) ... body)
|
||||
|
||||
(define-option if-wants-library-letrec* #t)
|
||||
|
||||
)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -25,8 +25,7 @@
|
|||
current-library-expander
|
||||
current-library-collection library-path library-extensions
|
||||
serialize-all current-precompiled-library-loader)
|
||||
(import (rnrs) (psyntax compat) (rnrs r5rs)
|
||||
(only (ikarus) fprintf))
|
||||
(import (rnrs) (psyntax compat) (rnrs r5rs))
|
||||
|
||||
(define (make-collection)
|
||||
(let ((set '()))
|
||||
|
|
@ -132,21 +131,8 @@
|
|||
(failed-list '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
(let ()
|
||||
(define-condition-type &library-resolution &condition
|
||||
make-library-resolution-condition
|
||||
library-resolution-condition?
|
||||
(library condition-library)
|
||||
(files condition-files))
|
||||
(raise
|
||||
(condition
|
||||
(make-error)
|
||||
(make-who-condition 'expander)
|
||||
(make-message-condition
|
||||
"cannot locate library in library-path")
|
||||
(make-library-resolution-condition
|
||||
x (reverse failed-list))))))
|
||||
((null? exts)
|
||||
(file-locator-resolution-error x (reverse failed-list)))
|
||||
((null? exts)
|
||||
(f (cdr ls) (library-extensions) failed-list))
|
||||
(else
|
||||
(let ((name (string-append (car ls) str (car exts))))
|
||||
|
|
@ -186,51 +172,47 @@
|
|||
((current-precompiled-library-loader)
|
||||
filename
|
||||
(case-lambda
|
||||
[(id name ver imp* vis* inv* exp-subst exp-env
|
||||
((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*)])
|
||||
(let f ((deps (append imp* vis* inv*)))
|
||||
(cond
|
||||
[(null? deps)
|
||||
((null? deps)
|
||||
(install-library id name ver imp* vis* inv*
|
||||
exp-subst exp-env visit-proc invoke-proc
|
||||
#f #f visible? #f)
|
||||
#t]
|
||||
[else
|
||||
(let ([d (car deps)])
|
||||
(let ([label (car d)] [dname (cadr d)])
|
||||
(let ([l (find-library-by-name dname)])
|
||||
#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
|
||||
(fprintf (current-error-port)
|
||||
"WARNING: library ~s has an inconsistent dependency \
|
||||
on library ~s; file ~s will be recompiled from \
|
||||
source.\n"
|
||||
name dname filename)
|
||||
#f]))))]))]
|
||||
[others #f])))
|
||||
((and (library? l) (eq? label (library-id l)))
|
||||
(f (cdr deps)))
|
||||
(else
|
||||
(library-version-mismatch-warning name dname filename)
|
||||
#f)))))))))
|
||||
(others #f))))
|
||||
|
||||
(define library-loader
|
||||
(make-parameter
|
||||
(lambda (x)
|
||||
(let ((file-name ((file-locator) x)))
|
||||
(cond
|
||||
[(not file-name)
|
||||
(assertion-violation #f "cannot file library" x)]
|
||||
[(try-load-from-file file-name)]
|
||||
[else
|
||||
((not file-name)
|
||||
(assertion-violation #f "cannot file library" x))
|
||||
((try-load-from-file file-name))
|
||||
(else
|
||||
((current-library-expander)
|
||||
(read-library-source-file file-name)
|
||||
file-name
|
||||
(lambda (name)
|
||||
(unless (equal? name x)
|
||||
(assertion-violation 'import
|
||||
(let-values ([(p e) (open-string-output-port)])
|
||||
(let-values (((p e) (open-string-output-port)))
|
||||
(display "expected to find library " p)
|
||||
(write x p)
|
||||
(display " in file " p)
|
||||
|
|
@ -238,7 +220,7 @@
|
|||
(display ", found " p)
|
||||
(write name p)
|
||||
(display " instead" p)
|
||||
(e))))))])))
|
||||
(e))))))))))
|
||||
(lambda (f)
|
||||
(if (procedure? f)
|
||||
f
|
||||
|
|
@ -310,7 +292,7 @@
|
|||
|
||||
(define install-library
|
||||
(case-lambda
|
||||
[(id name ver imp* vis* inv* exp-subst exp-env
|
||||
((id name ver imp* vis* inv* exp-subst exp-env
|
||||
visit-proc invoke-proc visit-code invoke-code
|
||||
visible? source-file-name)
|
||||
(let ((imp-lib* (map find-library-by-spec/die imp*))
|
||||
|
|
@ -325,7 +307,7 @@
|
|||
(let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib*
|
||||
exp-subst exp-env visit-proc invoke-proc
|
||||
visit-code invoke-code visible? source-file-name)))
|
||||
(install-library-record lib)))]))
|
||||
(install-library-record lib))))))
|
||||
|
||||
(define (imported-label->binding lab)
|
||||
(hashtable-ref label->binding-table lab #f))
|
||||
|
|
|
|||
Loading…
Reference in New Issue