(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 (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"
      :doc-group type
      :doc-see cons
      :doc-see list?]})
  (op brne)
  (op loadt)
  (op load0)
  (op loadc1)
  (op aref2)
  (op atom? 1 (λ (x) (atom? x))
    {[(v)
      «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»
      :doc-group type]})
  (op loadvoid)
  (op brnn)
  (op load1)
  (op < -1 (λ rest (apply < rest))
    {[(v . 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
      :doc-see cons?
      :doc-see 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."
      :doc-group type
      :doc-see sym
      :doc-see gensym?]})
  (op not 1 (λ (x) (not x))
    {[(v)
      "Return `T` if `v` is `NIL`, `T` otherwise."
      :doc-group syntax
      :doc-see and
      :doc-see or]})
  (op cadr 1 (λ (x) (cadr x))
    {[(lst)
      «Shorthand for `(car (cdr lst))`, 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."
      :doc-group number]})
  (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."
      :doc-group type
      :doc-group number
      :doc-see nan?]})
  (op fixnum? 1 (λ (x) (fixnum? x))
    {[(v)
      "Return `T` if `v` is of a fixnum type, `NIL` otherwise."
      :doc-group type
      :doc-group number
      :doc-see fixnum]})
  (op bound? 1 (λ (x) (bound? x))
    {[(sym)
      "Return `T` if `sym` has a value associated with it, `NIL` otherwise.

       Examples:

           (bound? 'bound?)
           ; ↳ T

           (bound? 'doesnotcompute)
           ; ↳ NIL"]})
  (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"
      :doc-group type
      :doc-see builtin
      :doc-see fn?
      :doc-see closure?]})
  (op fn? 1 (λ (x) (fn? x))
    {[(v)
      "Return `T` if `v` is a function, `NIL` otherwise.

       Examples:

           (fn? (void))
           ; ↳ NIL

           (fn? map)
           ; ↳ T

           (fn? macroexpand)
           ; ↳ T"
      :doc-group type
      :doc-see fn
      :doc-see builtin?
      :doc-see closure?]})
  (op vec? 1 (λ (x) (vec? x))
    {[(v)
      "Return `T` if `v` is a vector, `NIL` otherwise."
      :doc-group type]})
  (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) ; empty list
           ; ↳ NIL

           (list 1 2.5 "a" 'b)
           ; ↳ (1 2.5 "a" b)»
      :doc-see list?
      :doc-see cons]})
  (op apply -2 (λ rest (apply apply rest))
    {[(f arg . rest)
      "Return the result of applying a function `f` 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."
      :doc-group number]}
    :cname "ADD")
  (op - -1 (λ rest (apply - rest))
    {[(n . rest)
      "Return the result of subtraction.  With only one argument a
       negation is performed.

       Examples:

           (- 1.5)
           ; ↳ -1.5

           (- 3 2)
           ; ↳ 1"
      :doc-group number]}
    :cname "SUB")
  (op * T (λ rest (apply * rest))
    {[rest
      "Return product of the arguments or `1` when none specified."
      :doc-group number]}
    :cname "MUL")
  (op / -1 (λ rest (apply / rest))
    {[(n . 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…"
      :doc-group number
      :doc-see div0
      :doc-see div]}
    :cname "DIV")
  (op div0 2 (λ rest (apply div0 rest))
    {[(a n)
      "Return the quotient of the truncated division `a/n`.

       Examples:

           (div0 10 3)
           ; ↳ 3

           (div0 -10 3)
           ; ↳ -3

           (div0 -10 -3)
           ; ↳ 3

           (div0 10 -3)
           ; ↳ -3"
      :doc-group number
      :doc-see mod0
      :doc-see div]})
  (op = -1 (λ rest (apply = rest))
    {[(n . rest)
      "Numerical equality test.  Return `T` if all numbers are equal,
       `NIL` otherwise."
      :doc-group number
      :doc-group compare]}
    :cname "NUMEQP")
  (op compare 2 (λ (x y) (compare x y))
    {[(a b)
      «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»
      :doc-group compare]})
  (op argc)
  (op vec T (λ rest (apply vec rest))
    {[rest
      «Construct a vector containing the specified arguments.

       Examples:

           (vec) ; empty vector
           ; ↳ #()

           (vec 1 2.5 "a" 'b)
           ; ↳ #(1 2.5 "a" b)»
      :doc-group array
      :doc-see vec-alloc
      :doc-see arr]})
  (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))"
      :doc-group array
      :doc-see aref]})
  (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 optargs)
  (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"
      :doc-group array
      :doc-see aset!]})
  (op box.l)
  (op stkcons 2 (λ (x y) (stkcons x y)))
))

(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")
  (write `(doc-group builtin "Built-in operators.") docs-ops)
  (io-write docs-ops "\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* {[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 `(defdoc ,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 sl_builtin builtins[N_OPCODES];\n")

  (io-write c-code "#include \"sl.h\"\n\n")
  (io-write c-code "const sl_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-pos! c-header 0)
  (io-copy (new "opcodes.h") c-header)
  (io-pos! c-code 0)
  (io-copy (new "opcodes.c") c-code))