From 09dc7314445dee4ad62a12783207b92983e622eb Mon Sep 17 00:00:00 2001
From: John Lorentzson <john_lorentzson@yahoo.com>
Date: Tue, 8 Jul 2025 12:53:18 +0200
Subject: [PATCH] Add code to populate asm function table using listing
 declarations

---
 .../user-side-compiler/asm-function.lisp      |  24 +++-
 .../populate-asm-functions.lisp               | 112 ++++++++++++++++++
 .../user-side-compiler/user-side-compiler.asd |   1 +
 3 files changed, 132 insertions(+), 5 deletions(-)
 create mode 100644 wip-duuqnd/user-side-compiler/populate-asm-functions.lisp

diff --git a/wip-duuqnd/user-side-compiler/asm-function.lisp b/wip-duuqnd/user-side-compiler/asm-function.lisp
index 7e76ff8..90e8e23 100644
--- a/wip-duuqnd/user-side-compiler/asm-function.lisp
+++ b/wip-duuqnd/user-side-compiler/asm-function.lisp
@@ -2,17 +2,31 @@
 
 (defvar *asm-functions* (make-hash-table :test #'equalp))
 
+(defun asm-function-exists-p (name)
+  (not (null (gethash name *asm-functions*))))
+
+(defun get-asm-function (name)
+  (gethash name *asm-functions*))
+
 (defclass asm-function ()
   ((%name :accessor name :initarg :name)
-   (%address :accessor address :initarg :address
-             :initform #xFEC0)))
+   (%address :accessor address :initarg :address)))
+
+(defun add-asm-function (name address &key &allow-other-keys)
+  (when (or (not (asm-function-exists-p name))
+            (/= address (address (get-asm-function name))))
+    (setf (gethash name *asm-functions*)
+          (make-instance 'asm-function :name name :address address))))
 
 (tlk:define-simple-print-object (asm-function %name))
 
 (define-transformation (token (token-name asm-function))
   (multiple-value-bind (asm-function existsp)
-      (gethash (name token) *asm-functions*)
+      (get-asm-function (name token))
     (if existsp
         asm-function
-        (setf (gethash (name token) *asm-functions*)
-              (make-instance 'asm-function :name (name token))))))
+        (progn
+          (cerror "Create dummy function with placeholder address."
+                  "Tried to transform token into non-existent function ~A."
+                  (name token))
+          (add-asm-function (name token) #xC0FE)))))
diff --git a/wip-duuqnd/user-side-compiler/populate-asm-functions.lisp b/wip-duuqnd/user-side-compiler/populate-asm-functions.lisp
new file mode 100644
index 0000000..6ad339a
--- /dev/null
+++ b/wip-duuqnd/user-side-compiler/populate-asm-functions.lisp
@@ -0,0 +1,112 @@
+(in-package #:user-side-compiler)
+
+(defun get-line-comment (line)
+  (unless (zerop (length line))
+    (let ((index
+            (loop :with got-it-p := nil
+                  :for index :from 0
+                  :for char := (char line index)
+                  :when (char= char #\;)
+                    :do (setf got-it-p t)
+                  :until (or (and got-it-p (char/= char #\;))
+                             (= (1+ index) (length line)))
+                  :finally (return
+                             (if (= (1+ index) (length line))
+                                 nil
+                                 index)))))
+      (unless (null index)
+        (subseq line index)))))
+
+(defun parse-asm-label (string)
+  (flet
+      ((name-char-p (char)
+         (or (alphanumericp char) (char= char #\_))))
+    (cond
+      ((zerop (length string))
+       nil)
+      ;; if it's an assembler macro, check that it's .proc
+      ((and (char= (char string 0) #\.)
+            (string-equal (subseq string 0 5) ".proc")
+            (whitespacep (char string 5)))
+       (let* ((start (position-if-not #'whitespacep string :start 5))
+              (end (position-if-not #'name-char-p string :start start)))
+         (subseq string start end)))
+      ;; Regular colon label (ROUTINE_NAME:)
+      ((loop :for char :across string
+             :until (char= char #\:)
+             :always (name-char-p char))
+       (subseq string 0 (position #\: string))))))
+
+(defun asm-declaration-p (string)
+  (let ((comment (get-line-comment string))
+        (label (parse-asm-label string)))
+    (and (search "user-procedure" comment :test #'char-equal) label)))
+
+(defun parse-asm-declaration (string)
+  (assert (asm-declaration-p string))
+  (let ((routine-name (parse-asm-label string))
+        (declaration (get-line-comment string)))
+    (with-input-from-string (input declaration)
+      (list routine-name
+            (let ((*read-eval* nil)
+                  (eof '#.(gensym)))
+              (loop :for obj := (read input nil eof)
+                    :until (eql obj eof)
+                    :collect obj))))))
+
+(defun find-declarations-in-listing (filepath)
+  (with-open-file (stream filepath)
+    (loop :for line := (read-line stream)
+          :until (and (not (zerop (length line)))
+                      (digit-char-p (char line 0))))
+    (loop :for line := (read-line stream nil :eof)
+          :until (eql line :eof)
+          :for address := (parse-integer line :start 0 :end 6 :radix 16)
+          :for main-text := (subseq line 24)
+          :when (asm-declaration-p main-text)
+            :collect (destructuring-bind (name declaration)
+                         (parse-asm-declaration main-text)
+                       (list name address declaration)))))
+
+(defparameter *program-listing-filepath* #P"../../wip-hugo/program.lst")
+(defparameter *program-build-filepath* #P"../../wip-hugo/build.sh")
+
+(defun check-for-asm-build-script ()
+  (do ((path *program-build-filepath*))
+      ((probe-file path) path)
+    (restart-case
+        (error "Couldn't find assembly build script ~S." path)
+      (use-value (filepath)
+        :report "Specify a different path to the build script."
+        :interactive (lambda ()
+                       (format t "Enter new pathname (evaled): ")
+                       (eval (read)))
+        (setf path filepath)))))
+
+(defun build-assembly-program ()
+  (let ((script-path (check-for-asm-build-script))
+        (current-dir (uiop:getcwd)))
+    (unwind-protect
+         (progn
+           (uiop:chdir (make-pathname :defaults script-path
+                                      :name nil :type nil))
+           (uiop:run-program (namestring
+                              (make-pathname :defaults script-path
+                                             :directory '(:relative ".")))))
+      (uiop:chdir current-dir))))
+
+(defun check-for-assembly-listing ()
+  (do ((listing *program-listing-filepath*))
+      ((probe-file listing) listing)
+    (restart-case
+        (error "Couldn't find assembly listing ~S." listing)
+      (build-program ()
+        :report "Build the assembly program to generate listing."
+        (build-assembly-program)))))
+
+(defun populate-asm-functions ()
+  (let* ((listing (check-for-assembly-listing))
+         (routine-info (find-declarations-in-listing listing)))
+    (loop :for (name address declaration) :in routine-info
+          ;; TODO: Use declaration info
+          :do (add-asm-function name address))))
diff --git a/wip-duuqnd/user-side-compiler/user-side-compiler.asd b/wip-duuqnd/user-side-compiler/user-side-compiler.asd
index b82e539..12121db 100644
--- a/wip-duuqnd/user-side-compiler/user-side-compiler.asd
+++ b/wip-duuqnd/user-side-compiler/user-side-compiler.asd
@@ -12,6 +12,7 @@
    (:file "symbol-table")
    (:file "tokenizer")
    (:file "asm-function")
+   (:file "populate-asm-functions")
    (:file "high-level")
    (:file "parser")
    (:file "label")