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

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)

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)
+  (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)])
-          (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)
   

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

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) 

scheme/last-revision

@@ -1 +1 @@
-1726
+1728

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]

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)

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 (position->condition x)
-    (define-condition-type &source-information &condition
-      make-source-condition source-condition?
-      (file-name source-filename)
-      (character source-character))
     (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)