made public source-position conditions and load-r6rs-script.

This commit is contained in:
Abdulaziz Ghuloum 2008-12-27 00:36:13 -05:00
parent 79e62bf5d5
commit ce4dc64e0d
10 changed files with 47 additions and 33 deletions

Binary file not shown.

Binary file not shown.

View File

@ -51,6 +51,8 @@
no-infinities-violation? make-no-infinities-violation no-infinities-violation? make-no-infinities-violation
no-nans-violation? make-no-nans-violation no-nans-violation? make-no-nans-violation
interrupted-condition? make-interrupted-condition 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 &condition-rtd &condition-rcd &message-rtd &message-rcd
&warning-rtd &warning-rcd &serious-rtd &serious-rcd &warning-rtd &warning-rcd &serious-rtd &serious-rcd
@ -72,6 +74,7 @@
&i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd &i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd
&no-nans-rtd &no-nans-rcd &no-nans-rtd &no-nans-rcd
&interrupted-rtd &interrupted-rcd &interrupted-rtd &interrupted-rcd
&source-position-rtd &source-position-rcd
) )
(import (import
(rnrs records inspection) (rnrs records inspection)
@ -126,6 +129,8 @@
no-nans-violation? make-no-nans-violation no-nans-violation? make-no-nans-violation
interrupted-condition? make-interrupted-condition interrupted-condition? make-interrupted-condition
make-source-position-condition source-position-condition?
source-position-file-name source-position-character
)) ))
(define-record-type &condition (define-record-type &condition
@ -335,6 +340,11 @@
(define-condition-type &interrupted &serious (define-condition-type &interrupted &serious
make-interrupted-condition interrupted-condition?) 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 (define print-condition
(let () (let ()
(define (print-simple-condition x p) (define (print-simple-condition x p)

View File

@ -15,9 +15,9 @@
(library (ikarus load) (library (ikarus load)
(export load load-r6rs-top-level) (export load load-r6rs-script)
(import (import
(except (ikarus) load) (except (ikarus) load load-r6rs-script)
(only (ikarus.compiler) compile-core-expr) (only (ikarus.compiler) compile-core-expr)
(only (psyntax library-manager) (only (psyntax library-manager)
serialize-all current-precompiled-library-loader) serialize-all current-precompiled-library-loader)
@ -86,19 +86,20 @@
(set! ls (cdr ls)) (set! ls (cdr ls))
(eval-proc a)) (eval-proc a))
(f))))])) (f))))]))
(define load-r6rs-top-level
(lambda (x how) (define load-r6rs-script
(let ([prog (read-script-source-file x)]) (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)]) (let ([thunk (compile-r6rs-top-level prog)])
(case how (when serialize?
[(run) (thunk)] (serialize-all
[(compile) (lambda (file-name contents)
(serialize-all (do-serialize-library file-name contents))
(lambda (file-name contents) (lambda (core-expr)
(do-serialize-library file-name contents)) (compile-core-expr core-expr))))
(lambda (core-expr) (when run? (thunk))))))
(compile-core-expr core-expr)))]
[else (error 'load-r6rs-top-level "invali argument" how)])))))
(current-precompiled-library-loader load-serialized-library) (current-precompiled-library-loader load-serialized-library)

View File

@ -73,12 +73,12 @@
(library (ikarus main) (library (ikarus main)
(export) (export)
(import (ikarus) (import (except (ikarus) load-r6rs-script)
(except (ikarus startup) host-info) (except (ikarus startup) host-info)
(only (psyntax library-manager) current-library-expander) (only (psyntax library-manager) current-library-expander)
(only (ikarus.reader.annotated) read-source-file) (only (ikarus.reader.annotated) read-source-file)
(only (ikarus.symbol-table) initialize-symbol-table!) (only (ikarus.symbol-table) initialize-symbol-table!)
(only (ikarus load) load-r6rs-top-level)) (only (ikarus load) load-r6rs-script))
(initialize-symbol-table!) (initialize-symbol-table!)
(init-library-path) (init-library-path)
(let-values ([(files script script-type args) (let-values ([(files script script-type args)
@ -136,12 +136,12 @@
((current-library-expander) src)) ((current-library-expander) src))
(read-source-file filename))) (read-source-file filename)))
files) files)
(load-r6rs-top-level script 'run) (load-r6rs-script script #f #t)
(exit 0)] (exit 0)]
[(eq? script-type 'compile) [(eq? script-type 'compile)
(assert-null files "--compile-dependencies") (assert-null files "--compile-dependencies")
(command-line-arguments (cons script args)) (command-line-arguments (cons script args))
(load-r6rs-top-level script 'compile) (load-r6rs-script script #t #f)
(exit 0)] (exit 0)]
[(eq? script-type 'script) ; no greeting, no cafe [(eq? script-type 'script) ; no greeting, no cafe
(command-line-arguments (cons script args)) (command-line-arguments (cons script args))

View File

@ -31,10 +31,6 @@
annotation-expression annotation-source annotation-stripped)) annotation-expression annotation-source annotation-stripped))
(define (die/lex id pos who msg arg*) (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 (raise
(condition (condition
(make-lexical-violation) (make-lexical-violation)
@ -42,7 +38,7 @@
(if (null? arg*) (if (null? arg*)
(condition) (condition)
(make-irritants-condition arg*)) (make-irritants-condition arg*))
(make-lexical-position-condition (make-source-position-condition
id pos)))) id pos))))
(define (die/pos p off who msg arg*) (define (die/pos p off who msg arg*)
(die/lex (port-id p) (die/lex (port-id p)

View File

@ -1 +1 @@
1726 1728

View File

@ -218,6 +218,7 @@
[&no-infinities ($core-rtd . (&no-infinities-rtd &no-infinities-rcd ))] [&no-infinities ($core-rtd . (&no-infinities-rtd &no-infinities-rcd ))]
[&no-nans ($core-rtd . (&no-nans-rtd &no-nans-rcd))] [&no-nans ($core-rtd . (&no-nans-rtd &no-nans-rcd))]
[&interrupted ($core-rtd . (&interrupted-rtd &interrupted-rcd))] [&interrupted ($core-rtd . (&interrupted-rtd &interrupted-rcd))]
[&source ($core-rtd . (&source-rtd &source-rcd))]
)) ))
(define library-legend (define library-legend
@ -569,6 +570,12 @@
[$swap-engine-counter! $interrupts] [$swap-engine-counter! $interrupts]
[interrupted-condition? i] [interrupted-condition? i]
[make-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 ] [$apply-nonprocedure-error-handler ]
[$incorrect-args-error-handler ] [$incorrect-args-error-handler ]
[$multiple-values-error ] [$multiple-values-error ]
@ -1350,6 +1357,7 @@
[nanosleep i] [nanosleep i]
[char-ready? ] [char-ready? ]
[load i] [load i]
[load-r6rs-script i]
[void i $boot] [void i $boot]
[gensym i symbols $boot] [gensym i symbols $boot]
[symbol-value i symbols $boot] [symbol-value i symbols $boot]
@ -1453,6 +1461,8 @@
[&no-nans-rcd] [&no-nans-rcd]
[&interrupted-rtd] [&interrupted-rtd]
[&interrupted-rcd] [&interrupted-rcd]
[&source-rtd]
[&source-rcd]
[tcp-connect i] [tcp-connect i]
[udp-connect i] [udp-connect i]
[tcp-connect-nonblocking i] [tcp-connect-nonblocking i]

View File

@ -23,7 +23,8 @@
read-library-source-file read-library-source-file
library-version-mismatch-warning library-version-mismatch-warning
file-locator-resolution-error file-locator-resolution-error
label-binding set-label-binding! remove-location) label-binding set-label-binding! remove-location
make-source-position-condition)
(import (import
(only (ikarus.compiler) eval-core) (only (ikarus.compiler) eval-core)
(only (ikarus.reader.annotated) read-library-source-file) (only (ikarus.reader.annotated) read-library-source-file)

View File

@ -3904,17 +3904,13 @@
(assertion-violation 'bound-identifier=? "not an identifier" y)) (assertion-violation 'bound-identifier=? "not an identifier" y))
(assertion-violation 'bound-identifier=? "not an identifier" x)))) (assertion-violation 'bound-identifier=? "not an identifier" x))))
(define (make-source-condition x) (define (position->condition x)
(define-condition-type &source-information &condition
make-source-condition source-condition?
(file-name source-filename)
(character source-character))
(if (pair? x) (if (pair? x)
(make-source-condition (car x) (cdr x)) (make-source-position-condition (car x) (cdr x))
(condition))) (condition)))
(define (extract-position-condition x) (define (extract-position-condition x)
(make-source-condition (expression-position x))) (position->condition (expression-position x)))
(define (expression-position x) (define (expression-position x)
(and (stx? x) (and (stx? x)
@ -3929,7 +3925,7 @@
(make-who-condition 'assert) (make-who-condition 'assert)
(make-message-condition "assertion failed") (make-message-condition "assertion failed")
(make-irritants-condition (list expr)) (make-irritants-condition (list expr))
(make-source-condition pos)))) (position->condition pos))))
(define syntax-error (define syntax-error
(lambda (x . args) (lambda (x . args)