ref: 62389c8990cafb8e99ae29b2bccbcd100ce4c7f0
dir: /gen.lsp/
(define opcodes '(
; C opcode, lisp compiler opcode, arg count, builtin lambda, DOC (NEW)
OP_LOADA0 loada0 #f 0 ()
OP_LOADA1 loada1 #f 0 ()
OP_LOADV loadv #f 0 ()
OP_BRF brf #f 0 ()
OP_POP pop #f 0 ()
OP_CALL call #f 0 ()
OP_TCALL tcall #f 0 ()
OP_LOADG loadg #f 0 ()
OP_LOADA loada #f 0 ()
OP_LOADC loadc #f 0 ()
OP_RET ret #f 0 ()
OP_DUP dup #f 0 ()
OP_CAR car 1 (λ (x) (car x)) (
((lst) "Returns the first element of a list or nil if not available."))
OP_CDR cdr 1 (λ (x) (cdr x)) (
((lst) "Returns the tail of a list or nil if not available."))
OP_CLOSURE closure #f 0 ()
OP_SETA seta #f 0 ()
OP_JMP jmp #f 0 ()
OP_LOADC0 loadc0 #f 0 ()
OP_CONSP cons? 1 (λ (x) (cons? x)) (
((value) "Returns #t if the value is a cons cell."))
OP_BRNE brne #f 0 ()
OP_LOADT loadt #f 0 ()
OP_LOAD0 load0 #f 0 ()
OP_LOADC1 loadc1 #f 0 ()
OP_AREF2 aref2 #f 0 ()
OP_ATOMP atom? 1 (λ (x) (atom? x)) ()
OP_BRT brt #f 0 ()
OP_BRNN brnn #f 0 ()
OP_LOAD1 load1 #f 0 ()
OP_LT < -1 (λ rest (apply < rest)) ()
OP_ADD2 add2 #f 0 ()
OP_SETCDR set-cdr! 2 (λ (x y) (set-cdr! x y)) ()
OP_LOADF loadf #f 0 ()
OP_CONS cons 2 (λ (x y) (cons x y)) ()
OP_EQ eq? 2 (λ (x y) (eq? x y)) ()
OP_SYMBOLP symbol? 1 (λ (x) (symbol? x)) ()
OP_NOT not 1 (λ (x) (not x)) ()
OP_CADR cadr 1 (λ (x) (cadr x)) ()
OP_NEG neg #f 0 ()
OP_NULLP null? 1 (λ (x) (null? x)) ()
OP_BOOLEANP boolean? 1 (λ (x) (boolean? x)) ()
OP_NUMBERP number? 1 (λ (x) (number? x)) ()
OP_FIXNUMP fixnum? 1 (λ (x) (fixnum? x)) ()
OP_BOUNDP bound? 1 (λ (x) (bound? x)) ()
OP_BUILTINP builtin? 1 (λ (x) (builtin? x)) ()
OP_FUNCTIONP function? 1 (λ (x) (function? x)) ()
OP_VECTORP vector? 1 (λ (x) (vector? x)) ()
OP_SHIFT shift #f 0 ()
OP_SETCAR set-car! 2 (λ (x y) (set-car! x y)) ()
OP_JMPL jmp.l #f 0 ()
OP_BRFL brf.l #f 0 ()
OP_BRTL brt.l #f 0 ()
OP_EQV eqv? 2 (λ (x y) (eqv? x y)) ()
OP_EQUAL equal? 2 (λ (x y) (equal? x y)) ()
OP_LIST list ANYARGS (λ rest rest) ()
OP_APPLY apply -2 (λ rest (apply apply rest)) ()
OP_ADD + ANYARGS (λ rest (apply + rest)) (
((number…) "Return sum of the numbers or 0 with no arguments."))
OP_SUB - -1 (λ rest (apply - rest)) ()
OP_MUL * ANYARGS (λ rest (apply * rest)) (
((number…) "Return product of the numbers or 1 with no arguments."))
OP_DIV / -1 (λ rest (apply / rest)) ()
OP_IDIV div0 2 (λ rest (apply div0 rest)) ()
OP_NUMEQ = -1 (λ rest (apply = rest)) ()
OP_COMPARE compare 2 (λ (x y) (compare x y)) ()
OP_ARGC argc #f 0 ()
OP_VECTOR vector ANYARGS (λ rest (apply vector rest)) ()
OP_ASET aset! -3 (λ rest (apply aset! rest)) ()
OP_LOADNIL loadnil #f 0 ()
OP_LOADI8 loadi8 #f 0 ()
OP_LOADVL loadv.l #f 0 ()
OP_LOADGL loadg.l #f 0 ()
OP_LOADAL loada.l #f 0 ()
OP_LOADCL loadc.l #f 0 ()
OP_SETG setg #f 0 ()
OP_SETGL setg.l #f 0 ()
OP_SETAL seta.l #f 0 ()
OP_VARGC vargc #f 0 ()
OP_TRYCATCH trycatch #f 0 ()
OP_FOR for 3 (λ (a b f) (for a b (λ (x) (f x)))) ()
OP_TAPPLY tapply #f 0 ()
OP_SUB2 sub2 #f 0 ()
OP_LARGC largc #f 0 ()
OP_LVARGC lvargc #f 0 ()
OP_CALLL call.l #f 0 ()
OP_TCALLL tcall.l #f 0 ()
OP_BRNEL brne.l #f 0 ()
OP_BRNNL brnn.l #f 0 ()
OP_BRN brn #f 0 ()
OP_BRNL brn.l #f 0 ()
OP_OPTARGS optargs #f 0 ()
OP_BRBOUND brbound #f 0 ()
OP_KEYARGS keyargs #f 0 ()
OP_BOX box #f 0 ()
OP_BOXL box.l #f 0 ()
OP_AREF aref -2 (λ rest (apply aref rest)) ()
OP_LOADVOID loadvoid #f 0 ()
OP_NANP nan? 1 (λ (x) (nan? x)) ()
OP_EOF_OBJECT dummy_eof #f 0 ()
))
(define (for-each-n f lst n)
(when (and (> n 0) (cons? lst))
(apply f (list-head lst n))
(for-each-n f (list-tail lst n) n)))
(let ((c-header (file "opcodes.h" :write :create :truncate))
(c-code (file "opcodes.c" :write :create :truncate))
(instructions (file "instructions.lsp" :write :create :truncate))
(builtins (file "builtins.lsp" :write :create :truncate))
(builtins-doc (file "docs_ops.lsp" :write :create :truncate))
(e (table))
(cl (table))
(ac (table))
(lms ())
(i 0))
(begin
(io-write c-header "typedef enum {\n")
(for-each-n
(λ (cop lop argc f docs)
(begin
(io-write c-header "\t")
(write cop c-header)
(io-write c-header ",\n")
(for-each (λ (doc)
(let ((docform (append `(,lop) (car doc))))
(write (append `(doc-for ,docform)
(list (cadr doc)))
builtins-doc)
(io-write builtins-doc "\n")))
docs)
(put! e lop i)
(when argc
(put! cl cop (list lop argc))
(when (and (number? argc) (>= argc 0))
(put! ac lop argc)))
(set! lms (cons f lms))
(set! i (1+ i))))
opcodes 5)
(io-close builtins-doc)
(io-write c-header "\tN_OPCODES\n}opcode_t;\n\n")
(io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
(io-close c-header)
(io-write c-code "#include \"flisp.h\"\n\n")
(io-write c-code "const Builtin builtins[N_OPCODES] = {\n")
(for-each
(λ (c la) (begin (io-write c-code "\t[")
(write c c-code)
(io-write c-code "] = {\"")
(write (car la) c-code)
(io-write c-code "\", ")
(write (cadr la) c-code)
(io-write c-code "},\n")))
cl)
(io-write c-code "};\n")
(io-close c-code)
(write `(define Instructions
"VM instructions mapped to their encoded byte representation."
,e)
instructions)
(io-write instructions "\n\n")
(write `(define arg-counts
"VM instructions mapped to their expected arguments count."
,ac)
instructions)
(io-write instructions "\n")
(io-close instructions)
(set! lms (cons vector (reverse! lms)))
(write `(define *builtins*
"VM instructions as closures."
,lms)
builtins)
(io-write builtins "\n")
(io-close builtins)))