From 1ff8ffb793a988de0bea7b3c7e663886801e9ce9 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 1 Jun 2024 11:06:53 -0700
Subject: Add: types.lisp, singletonc lasses, debugging instr.lisp

---
 src/instr.lisp | 87 ++++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 54 insertions(+), 33 deletions(-)

(limited to 'src/instr.lisp')

diff --git a/src/instr.lisp b/src/instr.lisp
index a5c94c6..db13941 100644
--- a/src/instr.lisp
+++ b/src/instr.lisp
@@ -1,45 +1,66 @@
 (defpackage #:sarcasm.instr
-  (:use #:cl)
+  (:use #:cl #:sarcasm.types)
   (:shadow cl:return cl:if cl:block cl:loop cl:t)
   (:local-nicknames
-   (#:a #:alexandria-2)))
+   (#:a #:alexandria-2))
+  (:export
+   ;; generic readers functions on every instruction 
+   #:instr-name
+   #:instr-code
+   #:instr-type))
 
 (in-package #:sarcasm.instr)
 
 (defclass instr () ())
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun expand-instr-plist (plist)
-    (destructuring-bind (&key instr code type) plist
-      (let* ((class-name
-               (intern (string-upcase (first instr))))
-             (immediates
-               (cl:loop
-                  :for arg :in (rest instr)
-                  :for slot-name := (intern (string-upcase arg))
-                  :for reader := (intern (format nil "~a-~a" class-name slot-name))
-                  :for initarg := (a:make-keyword slot-name)
-                  :collect `(,slot-name
-                             :reader ,reader
-                             :initarg ,initarg
-                             :initform (error "~a required" ',slot-name)))))
-        `(defclass ,class-name (instr)
-           ((instr-name
-             :allocation :class
-             :type string
-             :initform ,(first instr)
-             :reader instr-name)
-            (instr-code
-             :allocation :class
-             :type (vector (unsigned-byte 8) ,(length code))
-             :initform (make-array ,(length code)
-                                   :element-type '(unsigned-byte 8)
-                                   :initial-contents ',code))
-            (instr-type
-             :allocation :class
-             :type t
-             :initform ',type)
-            ,@immediates))))))
+  (let ((defined (make-hash-table :test #'eql)))
+    (defun expand-instr-plist (plist)
+      (destructuring-bind (&key instr code type) plist
+        (let* ((class-name
+                 (let ((class-name (intern (string-upcase (first instr)))))
+                   (cl:if (gethash class-name defined)
+                          (intern (format nil "~a_" class-name))
+                          class-name)))
+               (immediates
+                 (cl:loop
+                    :for arg :in (rest instr)
+                    :for slot-name := (intern (string-upcase arg))
+                    :for reader := (intern (format nil "~a-~a" class-name slot-name))
+                    :for initarg := (a:make-keyword slot-name)
+                    :collect `(,slot-name
+                               :reader ,reader
+                               :initarg ,initarg
+                               :initform (error "~a required" ',slot-name)))))
+
+          (setf (gethash class-name defined) cl:t)
+
+          `(progn
+             (format cl:t "DEFINING ~A~%" ',class-name)
+             (defclass ,class-name (instr)
+               ((instr-name
+                 :allocation :class
+                 :type string
+                 :initform ,(first instr)
+                 :reader instr-name)
+                (instr-code
+                 :allocation :class
+                 :type (vector (unsigned-byte 8) ,(length code))
+                 :initform (make-array ,(length code)
+                                       :element-type '(unsigned-byte 8)
+                                       :initial-contents ',code))
+                (instr-type
+                 :allocation :class
+                 :type stacksig
+                 :initform ',type)
+                ,@immediates)
+
+               ,@(when (not immediates)
+                   '((:metaclass sarcasm.util::singleton))))
+           
+             (export '(,class-name
+                       ,@(mapcar #'first immediates)
+                       ,@(mapcar #'third immediates)))))))))
 
 (macrolet ((create-instr-classes (raw)
              `(progn
-- 
cgit v1.2.3