1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
(defpackage #:sarcasm.instr
(:use #:cl #:sarcasm.types)
(:shadow cl:return cl:if cl:block cl:loop cl:t)
(:local-nicknames
(#: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)
(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
,@(mapcar #'expand-instr-plist raw))))
(create-instr-classes #.sarcasm.raw-instrs:raw-instrs))
|
