Add: types.lisp, singletonc lasses, debugging instr.lisp

6 files changed, 151 insertions, 92 deletions

diff --git a/sarcasm.asd b/sarcasm.asd
index dc8b4e8..0569a5d 100644
--- a/sarcasm.asd
+++ b/sarcasm.asd
@@ -5,8 +5,11 @@
   :author "Colin <colin@cicadas.surf>"
   :license  "GPL3"
   :version "0.0.1"
-  :depends-on (#:alexandria #:yacc)
+  :depends-on (#:alexandria #:closer-mop)
   :pathname "src/"
   :serial t
   :components ((:file "util")
+               (:file "types")
+               (:file "raw-instrs")
+               (:file "instr")
                (:file "ast")))
diff --git a/src/ast.lisp b/src/ast.lisp
index eef5c05..9987ddf 100644
--- a/src/ast.lisp
+++ b/src/ast.lisp
@@ -1,70 +1,16 @@
 (defpackage #:sarcasm.ast
-  (:use #:cl)
+  (:use #:cl #:sarcasm.types)
   (:import-from #:sarcasm.util #:def/class)
   (:local-nicknames
    (#:a #:alexandria-2)
-   (#:util #:sarcasm.util)))
+   (#:util #:sarcasm.util)
+   (#:instr #:sarcasm.instr)))
 
 (in-package #:sarcasm.ast)
 
 ;;; TYPES
 
 
-
-(deftype i32 ()
-  '(integer 0 #.(expt 2 32)))
-
-(deftype i64 ()
-  '(integer 0 #. (expt 2 64)))
-
-(deftype f32 ()
-  'single-float)
-
-(deftype f64 ()
-  'double-float)
-
-(deftype numtype ()
-  '(or i32 i64 f32 f64))
-
-(deftype typeidx ()
-  'i32)
-
-(deftype vectype ()
-  '(bit-vector 128))
-
-(deftype funcref ()
-  't)
-
-(deftype externref ()
-  't)
-
-(deftype reftype ()
-  '(or funcref externref))
-
-(deftype valtype ()
-  '(or numtype vectype reftype))
-
-(defun stack-effect-type-p (thing)
-  "A stack effect type is a two element list of lists of keywords.
-
-It describes the types of values consumed off the stack and returned
-to the stack by instructions."
-  (and (listp thing)
-       (= 2 (length thing))
-       (listp (first thing))
-       (listp (second thing))
-       (every #'keywordp (first thing))
-       (every #'keywordp (second thing))))
-
-(deftype stack-effect-type ()
-  "This is not part of the standard grammar, but appears implicitly in
-the WASM table of instructions found
-
- https://webassembly.github.io/spec/core/appendix/index-instructions.html
-
-In the `Type` column."
-  '(satisfies stack-effect-type-p))
-
 ;;; MODULE-STRUCTURES
 
 (def/class instr ()
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
diff --git a/src/raw-instrs.lisp b/src/raw-instrs.lisp
index 7fdbe66..dbb830d 100644
--- a/src/raw-instrs.lisp
+++ b/src/raw-instrs.lisp
@@ -518,4 +518,5 @@
     (:INSTR ("f64x2.vconvert_low_i32x4_s") :CODE (253 254 1) :TYPE
      ((:V128) (:V128)))
     (:INSTR ("f64x2.vconvert_low_i32x4_u") :CODE (253 255 1) :TYPE
-     ((:V128) (:V128)))))
\ No newline at end of file
+     ((:V128) (:V128)))))
+
diff --git a/src/types.lisp b/src/types.lisp
new file mode 100644
index 0000000..7bd9775
--- /dev/null
+++ b/src/types.lisp
@@ -0,0 +1,68 @@
+(defpackage #:sarcasm.types
+  (:use #:cl)
+  (:export
+   #:i32 #:i64 #:f32 #:f64
+   #:numtype
+   #:typeidx
+   #:vectype
+   #:funcref
+   #:externref
+   #:reftype
+   #:valtype
+   #:stacksig))
+
+(in-package #:sarcasm.types)
+
+(deftype i32 ()
+  '(integer 0 #.(expt 2 32)))
+
+(deftype i64 ()
+  '(integer 0 #. (expt 2 64)))
+
+(deftype f32 ()
+  'single-float)
+
+(deftype f64 ()
+  'double-float)
+
+(deftype numtype ()
+  '(or i32 i64 f32 f64))
+
+(deftype typeidx ()
+  'i32)
+
+(deftype vectype ()
+  '(bit-vector 128))
+
+(deftype funcref ()
+  't)
+
+(deftype externref ()
+  't)
+
+(deftype reftype ()
+  '(or funcref externref))
+
+(deftype valtype ()
+  '(or numtype vectype reftype))
+
+(defun stacksig-p (thing)
+  "A stack effect type is a two element list of lists of keywords.
+
+It describes the types of values consumed off the stack and returned
+to the stack by instructions."
+  (and (listp thing)
+       (= 2 (length thing))
+       (listp (first thing))
+       (listp (second thing))
+       (every #'keywordp (first thing))
+       (every #'keywordp (second thing))))
+
+(deftype stacksig ()
+  "This is not part of the standard grammar, but appears implicitly in
+the WASM table of instructions found
+
+ https://webassembly.github.io/spec/core/appendix/index-instructions.html
+
+In the `Type` column."
+  '(satisfies stack-effect-type-p))
diff --git a/src/util.lisp b/src/util.lisp
index 5899b36..e561778 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -82,3 +82,23 @@ CLASS-OPTIONS is a PLIST of class options."
       `(defclass ,name ,supers
          (,@slot-defs)
          ,@options))))
+
+;;; SINGLETON CLASSES
+
+(defclass singleton (closer-mop:standard-class)
+  ((instance :reader singleton-instance
+             :initarg :instance
+             :documentation "The instance of a singleton class."))
+  (:documentation "Metaclass for singleton classes."))
+
+
+(defmethod closer-mop:validate-superclass
+    ((sub singleton) (sup closer-mop:standard-class))
+  t)
+
+(defmethod make-instance ((class singleton) &rest kwargs)
+  (declare (ignorable kwargs))
+  (if (slot-boundp class 'instance)
+      (slot-value class 'instance)
+      (setf (slot-value class 'instance) (call-next-method))))
+