Fix bootstrap

gambit · Oct 18, 2023 · e51702f · e51702f
1 parent 556a884
commit e51702f
Show file tree

Hide file tree

Showing 4 changed files with 41 additions and 7 deletions.
diff --git a/gsc/_gsclib.scm b/gsc/_gsclib.scm
@@ -74,7 +74,7 @@
                       expression
                       (##make-source
                        expression
-                       (##make-locat (##path->container filename) 0 #f))))))
+                       (**make-locat (##path->container filename) 0 #f))))))
         (cond ((##not (or (##null? opts)
                           (##pair? opts)))
                (error "list expected for options: parameter")) ;;;;;;;
@@ -230,7 +230,7 @@
                       expression
                       (##make-source
                        expression
-                       (##make-locat (##path->container filename) 0 #f))))))
+                       (**make-locat (##path->container filename) 0 #f))))))
         (cond ((##not (or (##null? opts)
                           (##pair? opts)))
                (error "list expected for options: parameter")) ;;;;;;;

diff --git a/gsc/_host.scm b/gsc/_host.scm
@@ -815,8 +815,39 @@
 (define (format-filepos path filepos pinpoint?)
   (##format-filepos path filepos pinpoint?))
 
+;; TODO: remove after bootstrap
+(define (**make-locat container start-position end-position)
+  (if end-position
+      (vector container start-position end-position)
+      (vector container start-position)))
+
+;; TODO: remove after bootstrap
+(define (**locat-start-position locat)
+  (let ((container (vector-ref locat 0)))
+    (if (##source? container)
+        (**locat-start-position (source-locat container))
+        (vector-ref locat 1))))
+
+;; TODO: remove after bootstrap
+(define (**locat-end-position locat)
+  (let ((container (vector-ref locat 0)))
+    (if (##source? container)
+        (**locat-end-position (source-locat container))
+        (and (= (vector-length locat) 3)
+             (vector-ref locat 2)))))
+
 (define (**display-message-with-locat gen-message locat kind proc port)
-  (##display-message-with-locat gen-message locat kind proc port))
+  (let ((dmwl
+         (##global-var-ref
+          (##make-global-var '##display-message-with-locat))))
+    (if (##unbound? dmwl) ;; TODO: remove after bootstrap
+        (begin
+          (display "*** " port)
+          (display kind port)
+          (locat-show " IN " locat port)
+          (display " -- " port)
+          (gen-message port))
+        (dmwl gen-message locat kind proc port))))
 
 ;; The path functions are already defined by Gambit
 ;;(define path-expand path-expand)

diff --git a/gsc/_source.scm b/gsc/_source.scm
@@ -164,7 +164,7 @@
   (if loc
 
       (let ((filename (##container->path (##locat-container loc)))
-            (filepos (##locat-start-position loc)))
+            (filepos (**locat-start-position loc)))
         (if (string? filename) ; file?
             (let ((str (format-filepos filename filepos #t)))
               (if str
@@ -196,7 +196,7 @@
       (let* ((container (##locat-container loc))
              (path (##container->path container)))
         (if path
-            (let* ((position (##locat-start-position loc))
+            (let* ((position (**locat-start-position loc))
                    (filepos (##position->filepos position))
                    (line (+ (**filepos-line filepos) 1)))
               (cons path line))
@@ -392,7 +392,7 @@
         (##current-readtable)
         (lambda (re x)
           (make-source x
-                       (##make-locat (##port-name (macro-readenv-port re))
+                       (**make-locat (##port-name (macro-readenv-port re))
                                      (##filepos->position
                                       (macro-readenv-filepos re))
                                      (##filepos->position
@@ -427,7 +427,7 @@
          (if (source? x)
              x
              (let ((locat
-                    (##make-locat container
+                    (**make-locat container
                                   (##filepos->position
                                    (macro-readenv-filepos re))
                                   (##filepos->position

diff --git a/gsc/fixnum.scm b/gsc/fixnum.scm
@@ -26,6 +26,8 @@
 **comply-to-standard-scheme?
 **display-message-with-locat
 **in-new-compilation-ctx
+**locat-start-position ;; TODO: remove after bootstrap
+**locat-end-position ;; TODO: remove after bootstrap
 **macro-compilation-ctx-demand-modules
 **macro-compilation-ctx-meta-info
 **macro-compilation-ctx-supply-modules
@@ -34,6 +36,7 @@
 **macro-descr-expander
 **macro-descr-size
 **main-readtable ;; variable
+**make-locat ;; TODO: remove after bootstrap
 **make-macro-descr
 **meta-info->alist
 absent-object