From 2c1bab05d6c2debf71ea313901dc751a753880c4 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Thu, 28 Jul 2022 15:41:42 -0700
Subject: Use a better interface for linker.

---
 csc/linker-test.csc | 17 ++-----------
 csc/linker.csc      | 73 +++++++++++++++++++++++++++++++++++++----------------
 2 files changed, 53 insertions(+), 37 deletions(-)

(limited to 'csc')

diff --git a/csc/linker-test.csc b/csc/linker-test.csc
index 70e5e31..7b5d5db 100644
--- a/csc/linker-test.csc
+++ b/csc/linker-test.csc
@@ -16,17 +16,6 @@
   (begin
 
 
-    (define compare-globals
-      (make-comparer
-        (lambda (x)
-          (hash-bytevector (string->utf8 (sprintf "{}" x))))
-        (lambda (x y)
-          (cond
-            ((equal? x y) 0)
-            ((string<? (sprintf "{}" x) (sprintf "{}" y)) -1)
-            (else 1)))))
-
-
     (test link-labels
       (assert-equal
         '((jmp (const 3))
@@ -39,8 +28,7 @@
              (label 1)
              (jmp (label 0))
              (label init)
-             (jmp (label 0))))
-          (make-map compare-globals))))
+             (jmp (label 0)))))))
 
 
     (test link-labels-are-unique-per-program
@@ -59,8 +47,7 @@
             ((label 0)
              (jmp (label 0))
              (label init)
-             (jmp (label 0))))
-          (make-map compare-globals))))
+             (jmp (label 0)))))))
 
 
     (test link-globals
diff --git a/csc/linker.csc b/csc/linker.csc
index dc738b7..9095647 100644
--- a/csc/linker.csc
+++ b/csc/linker.csc
@@ -1,16 +1,25 @@
 (define-library (csc linker)
-  (export link)
+  (export
+    add-to-environment
+    compare-globals
+    link)
   (import (scheme base)
+          (only (csc format)
+            sprintf)
           (only (csc hash-map)
             compare-numbers
+            hash-bytevector
             insert
             lookup
+            make-comparer
             make-map
             map-for-each)
           (only (csc loop)
             loop
             return)
-          (only (csc match) match))
+          (only (csc match) match)
+          (only (scheme case-lambda)
+            case-lambda))
   (begin
     ; A CSC bytecode program is a list of opcodes and labels. An opcode is a
     ; list of an opcode and arguments. Arguments can be any of:
@@ -50,37 +59,57 @@
             finally (return m)))
 
 
-    (define (translate-globals program environment)
+    (define (add-to-environment environment programs)
       (define next-global-id 0)
       (map-for-each (lambda (k v)
                       (when (>= v next-global-id)
                         (set! next-global-id (+ 1 v))))
         environment)
-      (define (translate-global x)
-        (or (lookup environment x #f)
-            (let ((id next-global-id))
-              (set! next-global-id (+ 1 next-global-id))
-              (set! environment (insert environment x id))
-              id)))
+      (loop for opcode in (apply append programs)
+            do (loop for arg in (cdr opcode)
+                     do (match arg
+                          (('global name lib)
+                            (define id next-global-id)
+                            (set! next-global-id (+ 1 next-global-id))
+                            (set! environment (insert environment arg id))))))
+      environment)
+
+
+    (define compare-globals
+      (make-comparer
+        (lambda (x)
+          (hash-bytevector (string->utf8 (sprintf "{}" x))))
+        (lambda (x y)
+          (cond
+            ((equal? x y) 0)
+            ((string<? (sprintf "{}" x) (sprintf "{}" y)) -1)
+            (else 1)))))
+
+
+    (define (translate-globals program environment)
       (loop for opcode in program
             for op = (car opcode)
             for args = (cdr opcode)
             collect (cons op (loop for arg in args
                                    collect (match arg
                                              (('global x lib)
-                                               (list 'const (translate-global arg)))
+                                               (list 'const (lookup environment arg)))
                                              (_ arg))))))
 
 
-    (define (link programs environment)
-      (translate-globals
-        (loop for prog in programs
-              for off = 0 then (+ off (length converted-prog))
-              for converted-prog = (let ((prog-prelude (cons
-                                                         (list 'jmp '(label init))
-                                                         prog)))
-                                     (translate-labels
-                                       prog-prelude
-                                       (make-label-map off prog-prelude)))
-              append converted-prog)
-        environment))))
+    (define link
+      (case-lambda
+        ((programs environment)
+          (translate-globals
+            (loop for prog in programs
+                  for off = 0 then (+ off (length converted-prog))
+                  for converted-prog = (let ((prog-prelude (cons
+                                                             (list 'jmp '(label init))
+                                                             prog)))
+                                         (translate-labels
+                                           prog-prelude
+                                           (make-label-map off prog-prelude)))
+                  append converted-prog)
+            environment))
+        ((programs)
+          (link programs (add-to-environment (make-map compare-globals) programs)))))))
-- 
cgit v1.3.1