ref: ec4d8b26ab214f3b601db96d7effd78ea5da89c8
dir: /tools/gen.lsp/
(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 list or `NIL` if not available."]})
(op cdr 1 (λ (x) (cdr x))
'{[(lst)
"Return the tail of a list or `NIL` if not available."]})
(op closure)
(op seta)
(op jmp)
(op loadc0)
(op cons? 1 (λ (x) (cons? x))
'{[(value)
"Return `T` if the value is a cons cell, `NIL` otherwise."]})
(op brne)
(op loadt)
(op load0)
(op loadc1)
(op aref2)
(op atom? 1 (λ (x) (atom? x)))
(op loadvoid)
(op brnn)
(op load1)
(op < -1 (λ rest (apply < rest))
:cname "LT")
(op add2)
(op set-cdr! 2 (λ (x y) (set-cdr! x y)))
(op keyargs)
(op cons 2 (λ (x y) (cons x y)))
(op eq? 2 (λ (x y) (eq? x y)))
(op sym? 1 (λ (x) (sym? x)))
(op not 1 (λ (x) (not x)))
(op cadr 1 (λ (x) (cadr x)))
(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, `NIL` otherwise."]})
(op fn? 1 (λ (x) (fn? x))
'{[(v)
"Return `T` if `v` is a function, `NIL` otherwise."]})
(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)))
(op jmp.l)
(op brn.l)
(op box)
(op eqv? 2 (λ (x y) (eqv? x y)))
(op equal? 2 (λ (x y) (equal? x y)))
(op list T (λ rest rest))
(op apply -2 (λ rest (apply apply rest)))
(op + T (λ rest (apply + rest))
'{[(num…)
"Return sum of the numbers or `0` with no arguments."]}
:cname "ADD")
(op - -1 (λ rest (apply - rest))
:cname "SUB")
(op * T (λ rest (apply * rest))
'{[(num…)
"Return product of the numbers or `1` with no arguments."]}
:cname "MUL")
(op / -1 (λ rest (apply / rest))
:cname "DIV")
(op div0 2 (λ rest (apply div0 rest)))
(op = -1 (λ rest (apply = rest))
'{[(num…)
"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)))
(op aset! -3 (λ rest (apply aset! rest)))
(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))
'{[(seq subscript…)
"Return the sequence element by the subscripts. The sequence can be an
array, vector or a list.
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 (new "opcodes.h"))
(c-code (new "opcodes.c"))
(instructions (new "instructions.lsp"))
(builtins (new "builtins.lsp"))
(docs-ops (new "docs_ops.lsp"))
(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)
(write `(doc-for ,(cons lop (car doc)) ,(cadr doc))
docs-ops)
(io-write docs-ops "\n"))
(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-close c-header)
(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")
(io-close c-code)
(write `(def Instructions
"VM instructions mapped to their encoded byte representation."
,op-to-byte)
instructions)
(io-write instructions "\n\n")
(write `(def arg-counts
"VM instructions mapped to their expected arguments count."
,op-to-argc)
instructions)
(io-write instructions "\n")
(io-close instructions)
(set! op-to-closure (cons vec (reverse! op-to-closure)))
(write `(def *builtins*
"VM instructions as closures."
,op-to-closure)
builtins)
(io-write builtins "\n")
(io-close builtins))