ref: 24a71723ffbe92ccbdc088a078d776fb869b52ca
dir: /tools/gen.sl/
(defstruct op name cname nargs closure docs)
(def (rune-alphanumeric? r)
(or (rune-alphabetic? r)
(rune-numeric? r)))
(def (name->cname name)
(let {[cname (buffer)]}
(for 0 (1- (length name))
(λ (i) (let {[r (rune (aref name i))]}
(io-write cname
(cond [(rune-alphanumeric? r) (rune-upcase r)]
[(= r #\?) #\P]
[(= r #\_) #\_]
[else ""])))))
(io->str cname)))
(defmacro (op symbol (nargs NIL) (closure NIL) (docs NIL) (:cname NIL))
(let ((name (str symbol)))
`(make-op :name ,name
:cname ,(str "OP_" (or cname (name->cname name)))
:nargs ,nargs
:closure ',closure
:docs ',docs)))
(def ops (vec
(op loada0)
(op loada1)
(op loadv)
(op brn)
(op pop)
(op call)
(op tcall)
(op loadg)
(op loada)
(op loadc)
(op ret)
(op dup)
(op car 1 (λ (x) (car x))
{[(lst)
"Return the first element of a cons cell (head of a list) or `NIL` if
not available.
Examples:
(car NIL) → NIL
(car '(1 2 3)) → 1
(car '(1 . 2)) → 1"]})
(op cdr 1 (λ (x) (cdr x))
{[(lst)
"Return the second element of a cons cell (tail of a list) or `NIL` if
not available.
Examples:
(cdr NIL) → NIL
(cdr '(1 2 3)) → (2 3)
(cdr '(1 . 2)) → 2"]})
(op closure)
(op seta)
(op jmp)
(op loadc0)
(op cons? 1 (λ (x) (cons? x))
{[(v)
"Return `T` if `v` is a cons cell, `NIL` otherwise.
Examples:
(cons? 0) → NIL
(cons? NIL) → NIL
(cons? '(1)) → T"]})
(op brne)
(op loadt)
(op load0)
(op loadc1)
(op aref2)
(op atom? 1 (λ (x) (atom? x))
{[(value)
"Return `T` if `v` is a _not_ a cons cell, `NIL` otherwise. This is
the opposite of `cons?`.
The term \"atom\" comes from the idea of being indivisible.
Examples:
(atom? \"a\") → T
(atom? NIL) → T
(atom? '(1)) → NIL"]})
(op loadvoid)
(op brnn)
(op load1)
(op < -1 (λ rest (apply < rest))
{[(a . rest)
"Return `T` if the arguments are in strictly increasing order (next
one is greater than the previous one). With a single argument
the result is always `T`."]}
:cname "LT")
(op add2)
(op set-cdr! 2 (λ (x y) (set-cdr! x y))
{[(cell new-second)
"Modify a cons cell (a list) in-place by putting `new-second` as its
second element (tail of the list). Return the modified cons
cell (list).
Examples:
(def q '(1 2 3 4 5))
(set-cdr! q '(6 7)) → (1 6 7)
q → (1 6 7)"]})
(op keyargs)
(op cons 2 (λ (x y) (cons x y))
{[(first second)
"Return a cons cell containing two arguments.
Examples:
(cons 1 2) → (1 . 2)
(cons 1 '(2)) → (1 2)
(cons 1 (cons 2 (cons 3 NIL))) → (1 2 3)"]})
(op eq? 2 (λ (x y) (eq? x y))
{[(a b)
"Return `T` if `a` and `b` are the same object, `NIL` otherwise.
Examples:
(eq? 0.0 0) → NIL
(eq? 0 0) → T
(def a \"1\")
(def b \"1\")
(eq? a b) → NIL
(def a '(1))
(def b '(1))
(eq? a b) → NIL"]})
(op sym? 1 (λ (x) (sym? x))
{[(v)
"Return `T` if `v` is a symbol, `NIL` otherwise."]})
(op not 1 (λ (x) (not x))
{[(v)
"Return `T` if `v` is `NIL`, `T` otherwise."]})
(op cadr 1 (λ (x) (cadr x))
{[(cell)
"Shorthand for `(car (cdr cell))`, that is, \"first element of the
second element\".
Examples:
(cadr '(1 2 3)) → 2
(cadr '(1)) → NIL
(cadr NIL) → NIL"]})
(op neg)
(op nan? 1 (λ (x) (nan? x))
{[(v)
"Return `T` if `v` is a floating point representation of NaN, either
negative or positive, `NIL` otherwise."]})
(op brbound)
(op num? 1 (λ (x) (num? x))
{[(v)
"Return `T` if `v` is of a numerical type, `NIL` otherwise.
Numerical types include floating point, fixnum, bignum, etc.
Note: ironically, a NaN value is considered a number by this function
since it's only testing the _type_ of the value."]})
(op fixnum? 1 (λ (x) (fixnum? x))
{[(v)
"Return `T` if `v` is of a fixnum type, `NIL` otherwise."]})
(op bound? 1 (λ (x) (bound? x))
{[(symbol)
"Return `T` if `symbol` has a value associated with it, `NIL` otherwise."]})
(op builtin? 1 (λ (x) (builtin? x))
{[(v)
"Return `T` if `v` is a built-in function implemented in C, `NIL`
otherwise.
Examples:
(builtin? map) → T
(builtin? macroexpand) → NIL"]})
(op fn? 1 (λ (x) (fn? x))
{[(v)
"Return `T` if `v` is a function, `NIL` otherwise.
Examples:
(fn? map) → T
(fn? macroexpand) → T"]})
(op vec? 1 (λ (x) (vec? x))
{[(v)
"Return `T` if `v` is a vector, `NIL` otherwise."]})
(op shift)
(op set-car! 2 (λ (x y) (set-car! x y))
{[(cell new-first)
"Modify a cons cell (a list) in-place by putting `new-first` as its
first element (head of the list). Return the modified cons
cell (list).
Examples:
(def q '(1 2 3 4 5))
(set-car! q 0) → (0 6 7)
q → (0 6 7)"]})
(op jmp.l)
(op brn.l)
(op box)
(op eqv? 2 (λ (x y) (eqv? x y))
{[(a b)
"Return `T` if both `a` and `b` are of the same value and primitive
(leaf) type, `NIL` otherwise. Neither cons cell nor vector are not
considered primitive types as they may define deep structures.
Examples:
(eqv? 0.0 0) → NIL
(eqv? 0 0) → T
(def a \"1\")
(def b \"1\")
(eqv? a b) → T
(def a '(1))
(def b '(1))
(eqv? a b) → NIL"]})
(op equal? 2 (λ (x y) (equal? x y))
{[(a b)
"Return `T` if both `a` and `b` are of the same value. For non-leaf
types (cons cell and vector), the equality test is performed
throughout the whole structure of the values.
Examples:
(equal? 0.0 0) → NIL
(equal? 0 0) → T
(def a \"1\")
(def b \"1\")
(equal? a b) → T
(def a '(1))
(def b '(1))
(equal? a b) → T"]})
(op list T (λ rest rest)
{[rest
"Return a list constructed of the arguments.
Examples:
(list) → NIL ; empty list
(list 1 2.5 \"a\" 'b) → (1 2.5 \"a\" b)"]})
(op apply -2 (λ rest (apply apply rest))
{[(fn arg . rest)
"Return the result of applying a function to a list of arguments.
The last argument must always be a list which gets spliced as
arguments to the function.
Examples:
(apply + 1 2 '(3 4 5)) → 15
(apply vec '(1 2 3)) → #(3 4 5)
(apply arr 'u8 '(3 4 5)) → #vu8(3 4 5)"]})
(op + T (λ rest (apply + rest))
{[rest
"Return sum of the arguments or `0` when none specified."]}
:cname "ADD")
(op - -1 (λ rest (apply - rest))
{[(a . rest)
"Return the result of subtraction. With only one argument a
negation is performed.
Examples:
(- 1.5) → -1.5
(- 3 2) → 1"]}
:cname "SUB")
(op * T (λ rest (apply * rest))
{[rest
"Return product of the arguments or `1` when none specified."]}
:cname "MUL")
(op / -1 (λ rest (apply / rest))
{[(x . rest)
"Return the division of the arguments. With only one argument the
result of `1/x` is returned. If the result is integer-valued, it is
returned as an integer.
Examples:
(/ 2) → 0.5
(/ 7 2 2) → 1.75
(/ 10 -2) → -5 ; a fixnum
(/ 6.9 1.9) → 3.6315…"]}
:cname "DIV")
(op div0 2 (λ rest (apply div0 rest))
{[(a b)
"Return the quotient of two numbers. For non-integers this is
equivalent to `(div0 (floor a) (floor b))`. The result is always an
integer.
Examples:
(div0 7 2) → 3
(div0 10 -2) → -5
(div0 6.9 1.9) → 6"]})
(op = -1 (λ rest (apply = rest))
{[(a . rest)
"Numerical equality test. Return `T` if all numbers are equal,
`NIL` otherwise."]}
:cname "NUMEQP")
(op compare 2 (λ (x y) (compare x y))
{[(x y)
"Return -1 if `x` is less than `y`, 0 if equal, and `1` if `y` is
greater than `x`.
Examples:
(compare 'a 'b) → -1
(compare 1 1) → 0
(compare \"b\" \"a\") → 1"]})
(op argc)
(op vec T (λ rest (apply vec rest))
{[rest
"Return a vector constructed of the arguments.
Examples:
(vec) → #() ; empty vector
(vec 1 2.5 \"a\" 'b) → #(1 2.5 \"a\" b)"]})
(op aset! -3 (λ rest (apply aset! rest))
{[(sequence subscripts… new-value)
"Modify the sequence element specified by the subscripts and return the
new value. The sequence can be an array, vector, a list.
Multi-dimensional sequences of variating types are also supported.
Examples:
(def a '((1 #(2 (3)) 4)))
(aset! a 1 'x) → index 1 out of bounds
(aset! a 0 0 'x) → x
a → ((x #(2 (3)) 4))
(aset! a 0 1 9) → 9
a → ((x #(9 (3)) 4))"]})
(op loadnil)
(op loadi8)
(op loadv.l)
(op loadg.l)
(op loada.l)
(op loadc.l)
(op setg)
(op setg.l)
(op seta.l)
(op vargc)
(op trycatch)
(op for 3 (λ (a b f) (for a b (λ (x) (f x))))
{[(min max fn)
"Call the function `fn` with a single integer argument, starting from
`min` and ending with `max`.
Examples:
(for 0 2 (λ (i) (print (- 2 i)))) → 210"]})
(op tapply)
(op sub2)
(op argc.l)
(op vargc.l)
(op call.l)
(op tcall.l)
(op brne.l)
(op brnn.l)
(op aref -2 (λ rest (apply aref rest))
{[(sequence subscript0 . rest)
"Return the sequence element specified by the subscripts. The sequence
can be an array, vector, a list. Multi-dimensional sequences
of variating types are also supported.
Examples:
(def a '((1 #(2 (3)) 4)))
(aref a 0) → (1 (2 (3)) 4)
(aref a 1) → index 1 out of bounds
(aref a 0 0) → 1
(aref a 0 1 0) → 2
(aref a 0 2) → 4"]})
(op box.l)
(op optargs)
(op dummy_eof)
))
(def (new path)
(file path :write :create :truncate))
(let ((c-header (buffer)) ; to avoid broken code truncating valid files
(c-code (buffer))
(instructions (new "instructions.sl"))
(builtins (new "builtins.sl"))
(docs-ops (new "docs_ops.sl"))
(op-to-byte (table))
(c-op-to-op-arg (table))
(op-to-argc (table))
(op-to-closure ())
(i 0))
(io-write c-header "typedef enum {\n")
(for-each
(λ (op)
(let {[lop (sym (op-name op))]
[argc (op-nargs op)]}
(io-write c-header (str "\t" (op-cname op) ",\n"))
(for-each (λ (doc)
(let* {[args (car doc)]
[sig (cons lop args)]
[docargs (cdr doc)]
[docstr (car docargs)]}
(unless (str? docstr)
(error lop ": documentation must be a string"))
(unless (or (sym? sig) (cons? sig))
(error lop ": invalid signature"))
(write `(doc-for ,sig ,@docargs) docs-ops)
(newline docs-ops)))
(op-docs op))
(put! op-to-byte lop (byte i))
(when argc
(put! c-op-to-op-arg (op-cname op) (list lop (if (eq? argc T) 'ANYARGS argc)))
(when (and (num? argc) (>= argc 0))
(put! op-to-argc lop argc)))
(set! op-to-closure (cons (op-closure op) op-to-closure))
(set! i (1+ i))))
ops)
(io-close docs-ops)
(io-write c-header "\tN_OPCODES\n}sl_op;\n\n")
(io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
(io-write c-code "#include \"sl.h\"\n\n")
(io-write c-code "const Builtin builtins[N_OPCODES] = {\n")
(for-each
(λ (c la) (begin (io-write c-code (str "\t[" c))
(io-write c-code "] = {\"")
(write (car la) c-code)
(io-write c-code "\", ")
(write (cadr la) c-code)
(io-write c-code "},\n")))
c-op-to-op-arg)
(io-write c-code "};\n")
(write `(def Instructions
"VM instructions mapped to their encoded byte representation."
,op-to-byte)
instructions)
(newline instructions)
(newline instructions)
(write `(def arg-counts
"VM instructions mapped to their expected arguments count."
,op-to-argc)
instructions)
(newline instructions)
(io-close instructions)
(set! op-to-closure (cons vec (reverse! op-to-closure)))
(write `(def *builtins*
"VM instructions as closures."
,op-to-closure)
builtins)
(newline builtins)
(io-close builtins)
;; at last, copy the buffers to the actual files in git repo.
(io-seek c-header 0)
(io-copy (new "opcodes.h") c-header)
(io-seek c-code 0)
(io-copy (new "opcodes.c") c-code))