diff --git a/scheme/ikarus.boot.4.prebuilt b/scheme/ikarus.boot.4.prebuilt index 4f796af..457db5c 100644 Binary files a/scheme/ikarus.boot.4.prebuilt and b/scheme/ikarus.boot.4.prebuilt differ diff --git a/scheme/ikarus.boot.8.prebuilt b/scheme/ikarus.boot.8.prebuilt index 0d1afe7..1bdc918 100644 Binary files a/scheme/ikarus.boot.8.prebuilt and b/scheme/ikarus.boot.8.prebuilt differ diff --git a/scheme/ikarus.conditions.ss b/scheme/ikarus.conditions.ss index bab6989..621860e 100644 --- a/scheme/ikarus.conditions.ss +++ b/scheme/ikarus.conditions.ss @@ -51,6 +51,8 @@ no-infinities-violation? make-no-infinities-violation no-nans-violation? make-no-nans-violation interrupted-condition? make-interrupted-condition + make-source-position-condition source-position-condition? + source-position-file-name source-position-character &condition-rtd &condition-rcd &message-rtd &message-rcd &warning-rtd &warning-rcd &serious-rtd &serious-rcd @@ -72,6 +74,7 @@ &i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd &no-nans-rtd &no-nans-rcd &interrupted-rtd &interrupted-rcd + &source-position-rtd &source-position-rcd ) (import (rnrs records inspection) @@ -126,6 +129,8 @@ no-nans-violation? make-no-nans-violation interrupted-condition? make-interrupted-condition + make-source-position-condition source-position-condition? + source-position-file-name source-position-character )) (define-record-type &condition @@ -335,6 +340,11 @@ (define-condition-type &interrupted &serious make-interrupted-condition interrupted-condition?) + (define-condition-type &source-position &condition + make-source-position-condition source-position-condition? + (file-name source-position-file-name) + (character source-position-character)) + (define print-condition (let () (define (print-simple-condition x p) diff --git a/scheme/ikarus.load.ss b/scheme/ikarus.load.ss index 364586b..73d749f 100644 --- a/scheme/ikarus.load.ss +++ b/scheme/ikarus.load.ss @@ -15,9 +15,9 @@ (library (ikarus load) - (export load load-r6rs-top-level) + (export load load-r6rs-script) (import - (except (ikarus) load) + (except (ikarus) load load-r6rs-script) (only (ikarus.compiler) compile-core-expr) (only (psyntax library-manager) serialize-all current-precompiled-library-loader) @@ -86,19 +86,20 @@ (set! ls (cdr ls)) (eval-proc a)) (f))))])) - (define load-r6rs-top-level - (lambda (x how) - (let ([prog (read-script-source-file x)]) + + (define load-r6rs-script + (lambda (filename serialize? run?) + (unless (string? filename) + (die 'load-r6rs-script "file name is not a string" filename)) + (let ([prog (read-script-source-file filename)]) (let ([thunk (compile-r6rs-top-level prog)]) - (case how - [(run) (thunk)] - [(compile) - (serialize-all - (lambda (file-name contents) - (do-serialize-library file-name contents)) - (lambda (core-expr) - (compile-core-expr core-expr)))] - [else (error 'load-r6rs-top-level "invali argument" how)]))))) + (when serialize? + (serialize-all + (lambda (file-name contents) + (do-serialize-library file-name contents)) + (lambda (core-expr) + (compile-core-expr core-expr)))) + (when run? (thunk)))))) (current-precompiled-library-loader load-serialized-library) diff --git a/scheme/ikarus.main.ss b/scheme/ikarus.main.ss index faa6fe7..edc8964 100644 --- a/scheme/ikarus.main.ss +++ b/scheme/ikarus.main.ss @@ -73,12 +73,12 @@ (library (ikarus main) (export) - (import (ikarus) + (import (except (ikarus) load-r6rs-script) (except (ikarus startup) host-info) (only (psyntax library-manager) current-library-expander) (only (ikarus.reader.annotated) read-source-file) (only (ikarus.symbol-table) initialize-symbol-table!) - (only (ikarus load) load-r6rs-top-level)) + (only (ikarus load) load-r6rs-script)) (initialize-symbol-table!) (init-library-path) (let-values ([(files script script-type args) @@ -136,12 +136,12 @@ ((current-library-expander) src)) (read-source-file filename))) files) - (load-r6rs-top-level script 'run) + (load-r6rs-script script #f #t) (exit 0)] [(eq? script-type 'compile) (assert-null files "--compile-dependencies") (command-line-arguments (cons script args)) - (load-r6rs-top-level script 'compile) + (load-r6rs-script script #t #f) (exit 0)] [(eq? script-type 'script) ; no greeting, no cafe (command-line-arguments (cons script args)) diff --git a/scheme/ikarus.reader.ss b/scheme/ikarus.reader.ss index d996d4f..d354e19 100644 --- a/scheme/ikarus.reader.ss +++ b/scheme/ikarus.reader.ss @@ -31,10 +31,6 @@ annotation-expression annotation-source annotation-stripped)) (define (die/lex id pos who msg arg*) - (define-condition-type &lexical-position &condition - make-lexical-position-condition lexical-position? - (file-name lexical-position-filename) - (character lexical-position-character)) (raise (condition (make-lexical-violation) @@ -42,7 +38,7 @@ (if (null? arg*) (condition) (make-irritants-condition arg*)) - (make-lexical-position-condition + (make-source-position-condition id pos)))) (define (die/pos p off who msg arg*) (die/lex (port-id p) diff --git a/scheme/last-revision b/scheme/last-revision index 921f45a..54c9fc8 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1726 +1728 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 395745e..473647c 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -218,6 +218,7 @@ [&no-infinities ($core-rtd . (&no-infinities-rtd &no-infinities-rcd ))] [&no-nans ($core-rtd . (&no-nans-rtd &no-nans-rcd))] [&interrupted ($core-rtd . (&interrupted-rtd &interrupted-rcd))] + [&source ($core-rtd . (&source-rtd &source-rcd))] )) (define library-legend @@ -569,6 +570,12 @@ [$swap-engine-counter! $interrupts] [interrupted-condition? i] [make-interrupted-condition i] + + [source-position-condition? i] + [make-source-position-condition i] + [source-position-file-name i] + [source-position-character i] + [$apply-nonprocedure-error-handler ] [$incorrect-args-error-handler ] [$multiple-values-error ] @@ -1350,6 +1357,7 @@ [nanosleep i] [char-ready? ] [load i] + [load-r6rs-script i] [void i $boot] [gensym i symbols $boot] [symbol-value i symbols $boot] @@ -1453,6 +1461,8 @@ [&no-nans-rcd] [&interrupted-rtd] [&interrupted-rcd] + [&source-rtd] + [&source-rcd] [tcp-connect i] [udp-connect i] [tcp-connect-nonblocking i] diff --git a/scheme/psyntax.compat.ss b/scheme/psyntax.compat.ss index d78c723..8cbba8a 100644 --- a/scheme/psyntax.compat.ss +++ b/scheme/psyntax.compat.ss @@ -23,7 +23,8 @@ read-library-source-file library-version-mismatch-warning file-locator-resolution-error - label-binding set-label-binding! remove-location) + label-binding set-label-binding! remove-location + make-source-position-condition) (import (only (ikarus.compiler) eval-core) (only (ikarus.reader.annotated) read-library-source-file) diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 4f9bc26..860b347 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -3904,17 +3904,13 @@ (assertion-violation 'bound-identifier=? "not an identifier" y)) (assertion-violation 'bound-identifier=? "not an identifier" x)))) - (define (make-source-condition x) - (define-condition-type &source-information &condition - make-source-condition source-condition? - (file-name source-filename) - (character source-character)) + (define (position->condition x) (if (pair? x) - (make-source-condition (car x) (cdr x)) + (make-source-position-condition (car x) (cdr x)) (condition))) (define (extract-position-condition x) - (make-source-condition (expression-position x))) + (position->condition (expression-position x))) (define (expression-position x) (and (stx? x) @@ -3929,7 +3925,7 @@ (make-who-condition 'assert) (make-message-condition "assertion failed") (make-irritants-condition (list expr)) - (make-source-condition pos)))) + (position->condition pos)))) (define syntax-error (lambda (x . args)