made public source-position conditions and load-r6rs-script.
This commit is contained in:
parent
79e62bf5d5
commit
ce4dc64e0d
Binary file not shown.
Binary file not shown.
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -1 +1 @@
|
|||
1726
|
||||
1728
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue