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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.4.prebuilt
View File

Binary file not shown.

BIN
scheme/ikarus.boot.8.prebuilt
View File

Binary file not shown.

10
scheme/ikarus.conditions.ss
View File

@ -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)

29
scheme/ikarus.load.ss
View File

@ -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)

8
scheme/ikarus.main.ss
View File

@ -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))

6
scheme/ikarus.reader.ss
View File

@ -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)

2
scheme/last-revision
View File

@ -1 +1 @@
1726
1728

10
scheme/makefile.ss
View File

@ -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]

3
scheme/psyntax.compat.ss
View File

@ -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)

12
scheme/psyntax.expander.ss
View 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)