2 Copyright (C) 2017-2018 Keziah Wesley
4 You can redistribute and/or modify this file under the terms of the
5 GNU Affero General Public License as published by the Free Software
6 Foundation, either version 3 of the License, or (at your option) any
9 This file is distributed in the hope that it will be useful, but
10 WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 Affero General Public License for more details.
14 You should have received a copy of the GNU Affero General Public
15 License along with this file. If not, see
16 <http://www.gnu.org/licenses/>.
19 <DEFINE result (expr) <STRING "*_res = (" .expr ");">>
21 <SETG opmname 1> ;"assembler name (e.g. GRTR?, SUB)"
22 <SETG opcode 2> ;"numeric opcode"
23 <SETG opargs 3> ;"argspec. see examples."
24 <SETG opbody-c 4> ;"C implementation (use names from argspec)"
25 <SETG opcname 5> ;"unique name (e.g. GRTRB, SUBB)"
27 <DEFINE def-ops ("TUPLE" ops "AUX" (i 0) (results '()) "NAME" act)
28 <COND (<EMPTY? .ops> <RETURN .results .act>)>
29 <SET results <CONS (<1 <2 .ops>> .i <REST <2 .ops>> <3 .ops> <UNPARSE <1 .ops>>) .results>>
30 <SET ops <REST <REST <REST .ops>>>>
34 <DEFINE def-name-to-opcode (ops "AUX" (rslt "enum {") "NAME" act)
35 <COND (<EMPTY? .ops> <RETURN <STRING .rslt "};"> .act>)>
36 <SET rslt <STRING .rslt "I_" <opcname <1 .ops>> "=" <UNPARSE <opcode <1 .ops>>> ",">>
40 <DEFINE def-opcode-to-name (ops "AUX" (rslt "const char * opcode_to_name (int op) { switch (op) {") "NAME" act)
41 <COND (<EMPTY? .ops> <RETURN <STRING .rslt "default: return 0;}}"> .act>)>
42 <SET rslt <STRING .rslt "case " <UNPARSE <opcode <1 .ops>>> ": return \"" <opcname <1 .ops>> "\";" ,CR>>
46 <DEFINE read-args (args "AUX" (acc "") (i 1) "NAME" act)
47 <COND (<EMPTY? .args> <RETURN .acc .act>)>
50 (<==? <1 .args> result>
51 <STRING "object * _res = RESULT(" <UNPARSE .i> ");" ,CR>)
54 (<==? <2 <1 .args>> BYTE>
55 <STRING "uint8_t " <UNPARSE <1 <1 .args>>> " = p[" <UNPARSE .i> "];" ,CR>)
56 (<==? <2 <1 .args>> OFFSET>
57 <STRING "int8_t " <UNPARSE <1 <1 .args>>> " = (int8_t)p[" <UNPARSE .i> "];" ,CR>)
58 (<==? <2 <1 .args>> FIX>
59 <STRING "int64_t " <UNPARSE <1 <1 .args>>> " = GETFIX(bp[p[" <UNPARSE .i> "]]);" ,CR>)
61 <SET args <REST .args>>
65 <DEFINE def-dispatch (ops
66 "AUX" (rslt <STRING "void run (const uint8_t * p0, const uint8_t * p, object * bp, int sp) {" ,CR
71 <COND (<EMPTY? .ops> <RETURN
72 <STRING .rslt "default: assert(0 && \"bad opcode\");" ,CR "}" ,CR "}" ,CR "}" ,CR> .act>)>
74 <STRING .rslt "case I_" <opcname <1 .ops>> ": {" ,CR
75 <read-args <opargs <1 .ops>>>
76 "const uint8_t * const oldp = p;" ,CR
77 "p += " <UNPARSE <+ 1 <LENGTH <opargs <1 .ops>>>>> !\; ,CR
78 <opbody-c <1 .ops>> ,CR
79 "break;" ,CR !\} ,CR>>
86 <DEFINE gen-opcode-fmt (op "AUX" (args <opargs .op>) (s "\"<%s") "NAME" act)
87 <COND (<EMPTY? .args> <RETURN <STRING .s ">\\n\""> .act>)>
91 (<==? <1 .args> result>
94 (<==? <2 <1 .args>> BYTE>
96 (<==? <2 <1 .args>> OFFSET>
98 (<==? <2 <1 .args>> FIX>
100 <SET args <REST .args>>
103 <DEFINE gen-opcode-args (op base "AUX"
104 (s <STRING ", \"" <opcname .op> "\"">)
106 (n <LENGTH <opargs .op>>))
108 <COND (<==? .i .n> <RETURN .s .act>)>
110 <SET s <STRING .s ", " .base "[" <UNPARSE .i> "]">>
113 <DEFINE def-disasm (ops
114 "AUX" (rslt <STRING "int snprint_op_disasm"
115 "(char ** buf, size_t outlen, const uint8_t ** p, size_t inlen)" ,CR
116 "{" ,CR "switch (**p) {" ,CR>)
118 <COND (<EMPTY? .ops> <RETURN <STRING .rslt "}" ,CR "return EBADOPCODE;" ,CR "}"> .act>)>
120 <STRING .rslt "case " <UNPARSE <opcode <1 .ops>>> ": " ,CR
121 "if (inlen < " <UNPARSE <LENGTH <opargs <1 .ops>>>> ") { return EBADOPARGS; };" ,CR
122 "*buf += snprintf(*buf, outlen, "
123 <gen-opcode-fmt <1 .ops>>
124 <gen-opcode-args <1 .ops> "(*p)">
126 "*p += " <UNPARSE <LENGTH <opargs <1 .ops>>>> ";" ,CR
128 <SET ops <REST .ops>>
132 GRTRB (GRTR? (x FIX) (rhs BYTE) (invert BYTE) (offs OFFSET))
133 "if (invert ^ (x > rhs)) JUMP(offs);"
134 SUB (SUB (x FIX) (y FIX) result) <result "NEWFIX( x - y )">
135 SUBB (SUB (x FIX) (rhs BYTE) result) <result "NEWFIX( x - rhs )">
136 MUL (MUL (x FIX) (y FIX) result) <result "NEWFIX( x * y )">
137 HALT (HALT) "return;">>
139 <PRINC <STRING "/*" ,LICENSE "*/">> <CRLF>
141 <PRINC <STRING "/* GENERATED FILE. CHANGES WILL BE OVERRIDDEN. " ,CR
142 "This file is generated by Muddle code; it is included "
143 "in the distribution for bootstrapping. */">> <CRLF>
145 <PRINC <def-name-to-opcode ,ops>> <CRLF>
146 ;<PRINC <def-opcode-to-name ,ops>> <CRLF>
148 <PRINC <def-dispatch ,ops>> <CRLF>
150 <PRINC <def-disasm ,ops>> <CRLF>
152 ;<PRINC <def-asm ,ops>> <CRLF>