ref: 5a4fb16e97cf9ed17c7d80cbfb17c7412d544da6
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- (str-length name))
(λ (i) (let {[r (str-rune name i)]}
(io-write cname
(cond [(rune-alphanumeric? r) (rune-upcase r)]
[(eq? r #\?) #\P]
[(eq? 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"
:doc-group list]})
(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"
:doc-group list]})
(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`."
:doc-group compare]}
: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)"
:doc-group list]})
(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)"
:doc-group list]})
(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»
:doc-group compare]})
(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»
:doc-group list]})
(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 bounda)
(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)"
:doc-group list]})
(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»
:doc-group compare]})
(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»
:doc-group compare]})
(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."
:doc-group compare]}
: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)
))
(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-u8 (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"))
(write `(doc-group builtin "Built-in operators.") docs-ops)
(for-each (λ (doc)
(let* {[formals (car doc)]
[signature (cons lop formals)]
[docargs (cdr doc)]
[docstr (car docargs)]}
(unless (str? docstr)
(error lop ": documentation must be a string"))
(unless (or (sym? signature) (cons? signature))
(error lop ": invalid signature"))
(write `(doc-for ,signature ,@docargs :doc-group builtin) docs-ops)
(newline docs-ops)))
(op-docs op))
(put! op-to-u8 lop (u8 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."
:doc-group builtin
,op-to-u8)
instructions)
(newline instructions)
(newline instructions)
(write `(def arg-counts
"VM instructions mapped to their expected arguments count."
:doc-group builtin
,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."
:doc-group builtin
,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))